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 21, 2013

Thank you the code is working flawlessly.

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.

I would need to make one change to the existing code. Move the start/insertion of data from the “D1” to “F1”.

Start a vertical list of all of the created columns in cell “D2” i.e. data from row 2

D2 - 6020
D3 - 6030 
D4 – 6040
Ext..
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")

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. 

Thanks I appreciate all of the assistance..

hiker95 · Dec 21, 2013

Javi,

Be back in a little while.

hiker95 · Dec 21, 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 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.

Javi · Dec 21, 2013

When the code creates the ranges is any way to have it reference the active worksheet name and not "listbyloc".

hiker95 · Dec 21, 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 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.

Javi · Dec 21, 2013

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...
[TABLE="width: 167"]
<TBODY>[TR]
[TD]branch
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6020
[/TD]
[TD]branch6020
[/TD]
[/TR]
[TR]
[TD]6030
[/TD]
[TD]branch6030
[/TD]
[/TR]
[TR]
[TD]6040
[/TD]
[TD]branch6040
[/TD]
[/TR]
[TR]
[TD]6050
[/TD]
[TD]branch6050
[/TD]
[/TR]
[TR]
[TD]6060
[/TD]
[TD]branch6060
[/TD]
[/TR]
[TR]
[TD]6070
[/TD]
[TD]branch6070
[/TD]
[/TR]
[TR]
[TD]6080
[/TD]
[TD]branch6080
[/TD]
[/TR]
[TR]
[TD]6100
[/TD]
[TD]branch6100
[/TD]
[/TR]
[TR]
[TD]6110
[/TD]
[TD]branch6110
[/TD]
[/TR]
[TR]
[TD]6120
[/TD]
[TD]branch6120
[/TD]
[/TR]
[TR]
[TD]6130
[/TD]
[TD]branch6130
[/TD]
[/TR]
[TR]
[TD]6150
[/TD]
[TD]branch6150
[/TD]
[/TR]
[TR]
[TD]6510
[/TD]
[TD]branch6510
[/TD]
[/TR]
[TR]
[TD]6520
[/TD]
[TD]branch6520
[/TD]
[/TR]
[TR]
[TD]6560
[/TD]
[TD]branch6560
[/TD]
[/TR]
[TR]
[TD]6570
[/TD]
[TD]branch6570
[/TD]
[/TR]
[TR]
[TD]6580
[/TD]
[TD]branch6580
[/TD]
[/TR]
[TR]
[TD]6590
[/TD]
[TD]branch6590
[/TD]
[/TR]
[TR]
[TD]6900
[/TD]
[TD]branch6900
[/TD]
[/TR]
[TR]
[TD]6910
[/TD]
[TD]branch6910
[/TD]
[/TR]
[TR]
[TD]6920
[/TD]
[TD]branch6920
[/TD]
[/TR]
[TR]
[TD]6930
[/TD]
[TD]branch6930
[/TD]
[/TR]
[TR]
[TD]6940
[/TD]
[TD]branch6940
[/TD]
[/TR]
[TR]
[TD]6950
[/TD]
[TD]branch6950
[/TD]
[/TR]
</TBODY>[/TABLE]

hiker95 · Dec 21, 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 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.

Javi · Dec 22, 2013

Thanks Hiker95 we are all set.... Working like a charm....

hiker95 · Dec 22, 2013

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.

list creation assistance Vlookup? if statement? VBA code?

Javi

Active Member

Javi

Active Member

Excel Facts

hiker95

Well-known 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

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