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
Thank you the code is working flawlessly.
</SPAN>
I do have one more piece that I would like to try to work into the code. This would help with my lookup tables for the combo boxes if we can do this in the code and not have to do it manually, this would be fantastic.
</SPAN>
I would need to make one change to the existing code. Move the start/insertion of data from the “D1” to “F1”.</SPAN>


  1. Start a vertical list of all of the created columns in cell “D2” i.e. data from row 2</SPAN>
D2 - 6020</SPAN>
D3 - 6030 </SPAN>
D4 – 6040</SPAN>
Ext..</SPAN>
2. Create a range that includes this data in column “D” but also include the same cells column “E” (The name of the range would be "tech")</SPAN>

I apologize for not including this in the original question, however I didn't think we would be able to set the ranges in code. </SPAN>

Thanks I appreciate all of the assistance.. </SPAN>
 
Upvote 0

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
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 ReorgDataV5()
' hiker95, 12/21/2013
' http://www.mrexcel.com/forum/excel-questions/743073-list-creation-assistance-vlookup-if-statement-visual-basic-applications-code.html
Dim oa As Variant, od 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
  od = .Range("D2:D" & lrd)
  .Range("D1").Copy .Range("F1").Resize(, lrd - 1)
  .Range("F2").Resize(, lrd - 1) = Application.Transpose(.Range("D2:D" & lrd))
  .Range("F2").Resize(, lrd - 1).HorizontalAlignment = xlCenter
  .Range("D1:D" & lrd).ClearContents
  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 = 6
        .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 = 6
        .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
  .Range("D2").Resize(UBound(od, 1), UBound(od, 2)) = od
  lrd = .Cells(Rows.Count, 4).End(xlUp).Row
  ActiveWorkbook.Names.Add Name:="tech", RefersToR1C1:="=Listbyloc!R2C4:R" & lrd & "C5" & ""
  .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 ReorgDataV5 macro.
 
Upvote 0
When the code creates the ranges is any way to have it reference the active worksheet name and not "listbyloc".
 
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 ReorgDataV6()
' hiker95, 12/21/2013
' http://www.mrexcel.com/forum/excel-questions/743073-list-creation-assistance-vlookup-if-statement-visual-basic-applications-code.html
Dim oa As Variant, od As Variant
Dim r As Long, lra As Long, lrd As Long, n As Long, fc As Long, lrn As Long, asn As String
Application.ScreenUpdating = False
With ActiveSheet
  asn = ActiveSheet.Name
  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
  od = .Range("D2:D" & lrd)
  .Range("D1").Copy .Range("F1").Resize(, lrd - 1)
  .Range("F2").Resize(, lrd - 1) = Application.Transpose(.Range("D2:D" & lrd))
  .Range("F2").Resize(, lrd - 1).HorizontalAlignment = xlCenter
  .Range("D1:D" & lrd).ClearContents
  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 = 6
        .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:="=" & asn & "!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 = 6
        .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:="=" & asn & "!R3C" & fc & ":R" & lrn & "C" & fc & ""
    End If
    r = r + n - 1
  Next r
  .Range("A2").Resize(UBound(oa, 1), UBound(oa, 2)) = oa
  .Range("D2").Resize(UBound(od, 1), UBound(od, 2)) = od
  lrd = .Cells(Rows.Count, 4).End(xlUp).Row
  ActiveWorkbook.Names.Add Name:="tech", RefersToR1C1:="=" & asn & "!R2C4:R" & lrd & "C5" & ""
  .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 ReorgDataV6 macro.
 
Upvote 0
The last thing I need to happen is in column "E" I need to include word "branch" and the corresponding number from column "D".

I use the below code and it worked, However and because it's not associated with column "D" the range "E3:????" is an issue.

I'm sure you can do it much cleaner at the end of your code.

Code: 
Range("D1").Select
    ActiveCell.FormulaR1C1 = "branch"
    
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=R1C4&RC[-1]"
    Range("E2").Select
    Selection.Copy
    Range("E3:E33").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False


thank you for all the help...
branch</SPAN>
6020</SPAN>
branch6020</SPAN>
6030</SPAN>
branch6030</SPAN>
6040</SPAN>
branch6040</SPAN>
6050</SPAN>
branch6050</SPAN>
6060</SPAN>
branch6060</SPAN>
6070</SPAN>
branch6070</SPAN>
6080</SPAN>
branch6080</SPAN>
6100</SPAN>
branch6100</SPAN>
6110</SPAN>
branch6110</SPAN>
6120</SPAN>
branch6120</SPAN>
6130</SPAN>
branch6130</SPAN>
6150</SPAN>
branch6150</SPAN>
6510</SPAN>
branch6510</SPAN>
6520</SPAN>
branch6520</SPAN>
6560</SPAN>
branch6560</SPAN>
6570</SPAN>
branch6570</SPAN>
6580</SPAN>
branch6580</SPAN>
6590</SPAN>
branch6590</SPAN>
6900</SPAN>
branch6900</SPAN>
6910</SPAN>
branch6910</SPAN>
6920</SPAN>
branch6920</SPAN>
6930</SPAN>
branch6930</SPAN>
6940</SPAN>
branch6940</SPAN>
6950</SPAN>
branch6950</SPAN>

<TBODY>
</TBODY>
 
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 ReorgDataV7()
' hiker95, 12/21/2013
' http://www.mrexcel.com/forum/excel-questions/743073-list-creation-assistance-vlookup-if-statement-visual-basic-applications-code.html
Dim oa As Variant, od As Variant
Dim r As Long, lra As Long, lrd As Long, n As Long, fc As Long, lrn As Long, asn As String
Application.ScreenUpdating = False
With ActiveSheet
  asn = ActiveSheet.Name
  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
  od = .Range("D2:D" & lrd)
  .Range("D1").Copy .Range("F1").Resize(, lrd - 1)
  .Range("F2").Resize(, lrd - 1) = Application.Transpose(.Range("D2:D" & lrd))
  .Range("F2").Resize(, lrd - 1).HorizontalAlignment = xlCenter
  .Range("D1:D" & lrd).ClearContents
  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 = 6
        .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:="=" & asn & "!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 = 6
        .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:="=" & asn & "!R3C" & fc & ":R" & lrn & "C" & fc & ""
    End If
    r = r + n - 1
  Next r
  .Range("A2").Resize(UBound(oa, 1), UBound(oa, 2)) = oa
  .Range("D2").Resize(UBound(od, 1), UBound(od, 2)) = od
  lrd = .Cells(Rows.Count, 4).End(xlUp).Row
  With .Range("E2:E" & lrd)
    .FormulaR1C1 = "=""branch"" & RC[-1]"
    .Value = .Value
  End With
  ActiveWorkbook.Names.Add Name:="tech", RefersToR1C1:="=" & asn & "!R2C4:R" & lrd & "C5" & ""
  .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 ReorgDataV7 macro.
 
Upvote 0
Javi,

You are very welcome.

I am glad I was able to have been of some help to you.

And, please come back to this forum for any other questions you might have.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Guna13
  • Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
742
Guna13
Guna13
D
  • Question
VBA Code - the code is not pasting to the column I need it to.
Replies
2
Views
565
dragontbone
D
N
  • Question
why VBA code not working for copying data to next Sheet
Replies
7
Views
450
Noni
N
mehidy1437
  • Question
Final code required expert opinion
Replies
8
Views
698
mehidy1437
mehidy1437
aba1csims
  • Question
Need a VBA script to pull most recent training dates
Replies
4
Views
569
aba1csims
aba1csims

Forum statistics

Threads
1,214,657
Messages
6,120,777
Members
448,991
Latest member
Hanakoro

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