list creation assistance Vlookup? if statement? VBA code?

J

Javi

Active Member
Joined
May 26, 2011
Messages
440
Hi All,</SPAN>

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".
</SPAN>
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:confused:

Any suggestions or help would be appreciated.
</SPAN>
Data set: Column A - classroom numbers --- Column B student names example:
</SPAN>
A1-101 B1-Jim</SPAN>
A2-101 B2-Cindy</SPAN>
A3-102 B3-Tim</SPAN>
A4-102 B4-Dave</SPAN>
A5-102 B5-Mary</SPAN>
A6-102 B6-Bob</SPAN>
A7-103 B7-Chris</SPAN>
A8-103 B8-Sue</SPAN>
A9-104 B9-Jan</SPAN>

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”.</SPAN>

Column D</SPAN>
D1-Classroom</SPAN>
D2-101</SPAN>
D3-Jim</SPAN>
D4-Cindy</SPAN>

Column E</SPAN>
E1-Classroom</SPAN>
E2-102</SPAN>
E3-Tim</SPAN>
E4-Dave</SPAN>
E5-Mary</SPAN>
E6-Bob</SPAN>

Column F</SPAN>
F1-Classroom</SPAN>
F2-103</SPAN>
F7-Chris</SPAN>
F8-Sue</SPAN>
F9-Jan</SPAN>


Column H</SPAN>
H1-Classroom</SPAN>
H2-104</SPAN>
H9-Jan</SPAN>


Thanks again!!
 
Last edited:
Sort by date Sort by votes
Sorry I missed this question... Yes the names would need to be alphabetically ascending.
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
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.
 
Last edited:
Upvote 0
Thank you!!! this worked great!!! ... Does it have a limit of how many rows it can handle and column a or B?
 
Upvote 0
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?
Click to expand...

That may depend on the version of Excel that you are using. But, I do not think so.
 
Last edited:
Upvote 0
I appreciate your assistance and knowledge there is one more piece I would like to get your suggestions on.
</SPAN>
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? </SPAN>

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. </SPAN>
 
Upvote 0
Javi,

In reference to the next screenshot:


Excel 2007
D
1Branch
26020
3Chad L Lindner
4Charles D Stehlin
5Craig Y Clark
6David J Wyatt
7Dillon R Palmer
8Harry Wayne Mattox
9Jerry C Eubanks
10Jimmie L Deaton Jr.
11Joshua D Walker
12Justin M Peterkin
13Kenneth S Young Jr.
14Kevin Ray Taylor Jr.
15Kevin Taylor
16Krishna R Bell
17Larry A Swatman
18Michael R Helms
19Michael T Ganoe
20Michael W Bowen
21Nathan H Boyd Jr.
22Patricia A Duron-Nichols
23Paul G Snyder
24Philip T Troglin
25Richard P Horton
26Richie L Fischer
27Steven G Neal
28Victor A Mercado
29Wade 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?
 
Upvote 0
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"
 
Upvote 0
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.
 
Upvote 0
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")"
 
Upvote 0
Javi,

Thank you...Ecellent worked perfect!!!
Click to expand...

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
Click to expand...

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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
VBA code clean up
Replies
9
Views
592
mumps
mumps
Guna13
  • Question Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
1K
Guna13
Guna13
D
  • Question Question
VBA Code - the code is not pasting to the column I need it to.
Replies
2
Views
810
dragontbone
D
N
  • Question Question
why VBA code not working for copying data to next Sheet
Replies
7
Views
634
Noni
N
mehidy1437
  • Question Question
Final code required expert opinion
Replies
8
Views
928
mehidy1437
mehidy1437

Forum statistics

Threads
1,224,800
Messages
6,181,044
Members
453,014
Latest member
Chris258

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top