list creation assistance Vlookup? if statement? VBA code?

Javi · Dec 4, 2013

Hi All,

I am looking for some advice or direction on how to assemble multiple list from a (2) column of data set. Here is what I have as a data set in column “A” & "B".

FYI..I did come up with a sort/filter copy and paste solution code. However, I think it could be very error-prone.

I just cannot come up with any type of if statement and/or the Vlookup that would work

Any suggestions or help would be appreciated.

Data set: Column A - classroom numbers --- Column B student names example:

A1-101 B1-Jim
A2-101 B2-Cindy
A3-102 B3-Tim
A4-102 B4-Dave
A5-102 B5-Mary
A6-102 B6-Bob
A7-103 B7-Chris
A8-103 B8-Sue
A9-104 B9-Jan

This is what my destination looks like D1:AM50- will always have the value “classroom” and D2:AM50 will always represent the individual “room numbers”.

Column D
D1-Classroom
D2-101
D3-Jim
D4-Cindy

Column E
E1-Classroom
E2-102
E3-Tim
E4-Dave
E5-Mary
E6-Bob

Column F
F1-Classroom
F2-103
F7-Chris
F8-Sue
F9-Jan

Column H
H1-Classroom
H2-104
H9-Jan

Thanks again!!

Javi · Dec 19, 2013

Sorry I missed this question... Yes the names would need to be alphabetically ascending.

hiker95 · Dec 20, 2013

Javi,

With your raw data in worksheet Listbyloc

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code:

Option Explicit
Sub ReorgDataV2()
' hiker95, 12/20/2013
' http://www.mrexcel.com/forum/excel-questions/743073-list-creation-assistance-vlookup-if-statement-visual-basic-applications-code.html
Dim oa As Variant
Dim r As Long, lra As Long, lrd As Long, n As Long, fc As Long
Application.ScreenUpdating = False
With Sheets("Listbyloc")
  lra = .Cells(Rows.Count, 1).End(xlUp).Row
  oa = .Range("A2:B" & lra)
  .Range("A2:B" & lra).Sort key1:=.Range("A2"), order1:=1, key2:=.Range("B2"), order2:=1
  .Range("A1:A" & lra).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("D1"), Unique:=True
  .Range("C1").Copy .Range("D1")
  With .Range("D1")
    .Value = "Branch"
    .HorizontalAlignment = xlCenter
  End With
  lrd = .Cells(Rows.Count, 4).End(xlUp).Row
  .Range("D1").Copy .Range("E1").Resize(, lrd - 2)
  .Range("D2").Resize(, lrd - 1) = Application.Transpose(.Range("D2:D" & lrd))
  .Range("D2").Resize(, lrd - 1).HorizontalAlignment = xlCenter
  With .Range("D3:D" & lrd)
    .ClearContents
    .HorizontalAlignment = xlGeneral
  End With
  For r = 2 To lra
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n = 1 Then
      fc = 0
      On Error Resume Next
      fc = Application.Match(.Cells(r, 1), .Rows(2), 0)
      On Error GoTo 0
      If fc > 0 Then
        If fc = 1 Then fc = 4
        .Cells(3, fc).Value = .Cells(r, 2).Value
      End If
    ElseIf n > 1 Then
      fc = 0
      On Error Resume Next
      fc = Application.Match(.Cells(r, 1), .Rows(2), 0)
      On Error GoTo 0
      If fc > 0 Then
        If fc = 1 Then fc = 4
        .Cells(3, fc).Resize(n).Value = .Range("B" & r & ":B" & r + n - 1).Value
      End If
    End If
    r = r + n - 1
  Next r
  .Range("A2").Resize(UBound(oa, 1), UBound(oa, 2)) = oa
  .Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV2 macro.

Javi · Dec 20, 2013

Thank you!!! this worked great!!! ... Does it have a limit of how many rows it can handle and column a or B?

hiker95 · Dec 20, 2013

Javi,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

Does it have a limit of how many rows it can handle and column a or B?

That may depend on the version of Excel that you are using. But, I do not think so.

Javi · Dec 20, 2013

I appreciate your assistance and knowledge there is one more piece I would like to get your suggestions on.

The data that this code has created is to be used in a combo box lookup.

With that said I need each data set to have a defined range NAME is a way to add this into the code? 

As an example the defined name for column “D” could be “branch6020” …this would be adding row one and two labels to create the defined name “D1&D2” .

thanks again.

hiker95 · Dec 20, 2013

Javi,

In reference to the next screenshot:

Excel 2007

D

1

Branch

2

6020

3

Chad L Lindner

4

Charles D Stehlin

5

Craig Y Clark

6

David J Wyatt

7

Dillon R Palmer

8

Harry Wayne Mattox

9

Jerry C Eubanks

10

Jimmie L Deaton Jr.

11

Joshua D Walker

12

Justin M Peterkin

13

Kenneth S Young Jr.

14

Kevin Ray Taylor Jr.

15

Kevin Taylor

16

Krishna R Bell

17

Larry A Swatman

18

Michael R Helms

19

Michael T Ganoe

20

Michael W Bowen

21

Nathan H Boyd Jr.

22

Patricia A Duron-Nichols

23

Paul G Snyder

24

Philip T Troglin

25

Richard P Horton

26

Richie L Fischer

27

Steven G Neal

28

Victor A Mercado

29

Wade A Gadreault

30

Listbyloc

1. For what you are requesting, does cell D2 have to have a title, like Branch6020, or branch6020?

2. And, does the range name Branch6020, or branch6020, refer to range D2:29, or range D3:D29?

Javi · Dec 20, 2013

The data as it is in D2 now is perfect I would not want to change that.

The range "branch6020" would refer to "D3:D29"

hiker95 · Dec 20, 2013

Javi,

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code:

Option Explicit
Sub ReorgDataV3()
' hiker95, 12/20/2013
' http://www.mrexcel.com/forum/excel-questions/743073-list-creation-assistance-vlookup-if-statement-visual-basic-applications-code.html
Dim oa As Variant
Dim r As Long, lra As Long, lrd As Long, n As Long, fc As Long, lrn As Long
Application.ScreenUpdating = False
With Sheets("Listbyloc")
  lra = .Cells(Rows.Count, 1).End(xlUp).Row
  oa = .Range("A2:B" & lra)
  .Range("A2:B" & lra).Sort key1:=.Range("A2"), order1:=1, key2:=.Range("B2"), order2:=1
  .Range("A1:A" & lra).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("D1"), Unique:=True
  .Range("C1").Copy .Range("D1")
  With .Range("D1")
    .Value = "Branch"
    .HorizontalAlignment = xlCenter
  End With
  lrd = .Cells(Rows.Count, 4).End(xlUp).Row
  .Range("D1").Copy .Range("E1").Resize(, lrd - 2)
  .Range("D2").Resize(, lrd - 1) = Application.Transpose(.Range("D2:D" & lrd))
  .Range("D2").Resize(, lrd - 1).HorizontalAlignment = xlCenter
  With .Range("D3:D" & lrd)
    .ClearContents
    .HorizontalAlignment = xlGeneral
  End With
  For r = 2 To lra
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n = 1 Then
      fc = 0
      On Error Resume Next
      fc = Application.Match(.Cells(r, 1), .Rows(2), 0)
      On Error GoTo 0
      If fc > 0 Then
        If fc = 1 Then fc = 4
        .Cells(3, fc).Value = .Cells(r, 2).Value
      End If
      lrn = .Cells(Rows.Count, fc).End(xlUp).Row
      ActiveWorkbook.Names.Add Name:="branch" & .Cells(2, fc).Value, RefersToR1C1:="=Listbyloc!R3C" & fc & ":R" & lrn & "C" & fc & ""
    ElseIf n > 1 Then
      fc = 0
      On Error Resume Next
      fc = Application.Match(.Cells(r, 1), .Rows(2), 0)
      On Error GoTo 0
      If fc > 0 Then
        If fc = 1 Then fc = 4
        .Cells(3, fc).Resize(n).Value = .Range("B" & r & ":B" & r + n - 1).Value
      End If
      lrn = .Cells(Rows.Count, fc).End(xlUp).Row
      ActiveWorkbook.Names.Add Name:="branch" & .Cells(2, fc).Value, RefersToR1C1:="=Listbyloc!R3C" & fc & ":R" & lrn & "C" & fc & ""
    End If
    r = r + n - 1
  Next r
  .Range("A2").Resize(UBound(oa, 1), UBound(oa, 2)) = oa
  .Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV3 macro.

Javi · Dec 20, 2013

Thank you...Ecellent worked perfect!!!

How would I change this part of the code so that it operates witjin the active sheet and not that the sheet called out.... "With Sheets("Listbyloc")"

hiker95 · Dec 20, 2013

Javi,

Thank you...Ecellent worked perfect!!!

You are very welcome. Thanks for the feedback.

How would I change this part of the code so that it operates witjin the active sheet

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code:

Option Explicit
Sub ReorgDataV4()
' hiker95, 12/20/2013
' http://www.mrexcel.com/forum/excel-questions/743073-list-creation-assistance-vlookup-if-statement-visual-basic-applications-code.html
Dim oa As Variant
Dim r As Long, lra As Long, lrd As Long, n As Long, fc As Long, lrn As Long
Application.ScreenUpdating = False
With ActiveSheet
  lra = .Cells(Rows.Count, 1).End(xlUp).Row
  oa = .Range("A2:B" & lra)
  .Range("A2:B" & lra).Sort key1:=.Range("A2"), order1:=1, key2:=.Range("B2"), order2:=1
  .Range("A1:A" & lra).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("D1"), Unique:=True
  .Range("C1").Copy .Range("D1")
  With .Range("D1")
    .Value = "Branch"
    .HorizontalAlignment = xlCenter
  End With
  lrd = .Cells(Rows.Count, 4).End(xlUp).Row
  .Range("D1").Copy .Range("E1").Resize(, lrd - 2)
  .Range("D2").Resize(, lrd - 1) = Application.Transpose(.Range("D2:D" & lrd))
  .Range("D2").Resize(, lrd - 1).HorizontalAlignment = xlCenter
  With .Range("D3:D" & lrd)
    .ClearContents
    .HorizontalAlignment = xlGeneral
  End With
  For r = 2 To lra
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n = 1 Then
      fc = 0
      On Error Resume Next
      fc = Application.Match(.Cells(r, 1), .Rows(2), 0)
      On Error GoTo 0
      If fc > 0 Then
        If fc = 1 Then fc = 4
        .Cells(3, fc).Value = .Cells(r, 2).Value
      End If
      lrn = .Cells(Rows.Count, fc).End(xlUp).Row
      ActiveWorkbook.Names.Add Name:="branch" & .Cells(2, fc).Value, RefersToR1C1:="=Listbyloc!R3C" & fc & ":R" & lrn & "C" & fc & ""
    ElseIf n > 1 Then
      fc = 0
      On Error Resume Next
      fc = Application.Match(.Cells(r, 1), .Rows(2), 0)
      On Error GoTo 0
      If fc > 0 Then
        If fc = 1 Then fc = 4
        .Cells(3, fc).Resize(n).Value = .Range("B" & r & ":B" & r + n - 1).Value
      End If
      lrn = .Cells(Rows.Count, fc).End(xlUp).Row
      ActiveWorkbook.Names.Add Name:="branch" & .Cells(2, fc).Value, RefersToR1C1:="=Listbyloc!R3C" & fc & ":R" & lrn & "C" & fc & ""
    End If
    r = r + n - 1
  Next r
  .Range("A2").Resize(UBound(oa, 1), UBound(oa, 2)) = oa
  .Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV4 macro.

list creation assistance Vlookup? if statement? VBA code?

Javi

Active Member

Javi

Active Member

Excel Facts

hiker95

Well-known Member

Javi

Active Member

hiker95

Well-known Member

Javi

Active Member

hiker95

Well-known Member

Javi

Active Member

hiker95

Well-known Member

Javi

Active Member

hiker95

Well-known Member

Similar threads

Forum statistics

Share this page

list creation assistance Vlookup? if statement? VBA code?

Active Member

Active Member

Excel Facts

Well-known Member

Active Member

Well-known Member

Active Member

Well-known Member

Active Member

Well-known Member

Active Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock