VBA Macro to loop through Vlookup

[goobee]

I'm trying to create a macro that will do "one to many matches" and output them to a report. I cobbled together a very rough macro that sort of works but not really as requires range values to be manually changed each time. Ideally, I'm looking for a macro that will loop through, match and list the matches (as many time as necessary) in individual cells. For visualization, see the samples below that shows both my desired output and sample data.

Desired Output, the Customer ID from this list is used to match against the sample data. There can be thousands of Customers.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD="width: 98"]A[/TD]
[TD="width: 98"]B[/TD]
[TD="width: 87"]C[/TD]
[TD="width: 87"]D[/TD]
[TD="width: 87"]E[/TD]
[/TR]
[TR]
[TD="width: 98"]1[/TD]
[TD="width: 98"]Customer ID[/TD]
[TD="width: 87"]Order 1[/TD]
[TD="width: 87"]Order 2[/TD]
[TD="width: 87"]Order 3[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1918438[/TD]
[TD]Jackets[/TD]
[TD]Trousers[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]1920685[/TD]
[TD]Underwear[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]1920957[/TD]
[TD]Skirts[/TD]
[TD]Suits[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]1925561[/TD]
[TD]Parts[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]1927037[/TD]
[TD]Sweaters[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]1928615[/TD]
[TD]Boots[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]1929262[/TD]
[TD]Coats[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]1930361[/TD]
[TD]Shorts[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]1932335[/TD]
[TD]Slippers[/TD]
[TD]Dresses[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]1934871[/TD]
[TD]Waistcoats[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD]1956050[/TD]
[TD]Socks[/TD]
[TD]Hats[/TD]
[TD]Jackets[/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]1956575[/TD]
[TD]Trousers[/TD]
[TD]Underwear[/TD]
[TD]Suits[/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD]1956797[/TD]
[TD]Suits[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD]1959693[/TD]
[TD]Skirts[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]16[/TD]
[TD]1964578[/TD]
[TD]Parts[/TD]
[TD]Shoes[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]1978480[/TD]
[TD]Sweaters[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Sample Date. There can be many orders/reorders by customers.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD="width: 64"]A[/TD]
[TD="width: 98"]B[/TD]
[TD="width: 87"]C[/TD]
[TD="width: 97"]D[/TD]
[/TR]
[TR]
[TD]19[/TD]
[TD]Customer ID[/TD]
[TD]Order Date[/TD]
[TD]Item Ordered[/TD]
[/TR]
[TR]
[TD]20[/TD]
[TD]1918438[/TD]
[TD]3/12/2018[/TD]
[TD]Jackets[/TD]
[/TR]
[TR]
[TD]21[/TD]
[TD]1918438[/TD]
[TD]7/7/2018[/TD]
[TD]Trousers[/TD]
[/TR]
[TR]
[TD]22[/TD]
[TD]1920685[/TD]
[TD]9/24/2018[/TD]
[TD]Underwear[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]1920957[/TD]
[TD]3/30/2018[/TD]
[TD]Skirts[/TD]
[/TR]
[TR]
[TD]24[/TD]
[TD]1920957[/TD]
[TD]5/28/2018[/TD]
[TD]Suits[/TD]
[/TR]
[TR]
[TD]25[/TD]
[TD]1925561[/TD]
[TD]7/5/2018[/TD]
[TD]Shoes[/TD]
[/TR]
[TR]
[TD]26[/TD]
[TD]1925561[/TD]
[TD]10/23/2018[/TD]
[TD]Parts[/TD]
[/TR]
[TR]
[TD]27[/TD]
[TD]1927037[/TD]
[TD]12/6/2018[/TD]
[TD]Sweaters[/TD]
[/TR]
[TR]
[TD]28[/TD]
[TD]1928615[/TD]
[TD]1/9/2018[/TD]
[TD]Boots[/TD]
[/TR]
[TR]
[TD]28[/TD]
[TD]1929262[/TD]
[TD]9/24/2018[/TD]
[TD]Coats[/TD]
[/TR]
[TR]
[TD]30[/TD]
[TD]1930361[/TD]
[TD]9/24/2018[/TD]
[TD]Shorts[/TD]
[/TR]
[TR]
[TD]31[/TD]
[TD]1932335[/TD]
[TD]6/7/2018[/TD]
[TD]Slippers[/TD]
[/TR]
[TR]
[TD]32[/TD]
[TD]1932335[/TD]
[TD]7/8/2018[/TD]
[TD]Dresses[/TD]
[/TR]
[TR]
[TD]33[/TD]
[TD]1934871[/TD]
[TD]6/7/2018[/TD]
[TD]Waistcoats[/TD]
[/TR]
[TR]
[TD]34[/TD]
[TD]1956050[/TD]
[TD]2/19/2018[/TD]
[TD]Socks[/TD]
[/TR]
[TR]
[TD]35[/TD]
[TD]1956050[/TD]
[TD]2/19/2018[/TD]
[TD]Hats[/TD]
[/TR]
[TR]
[TD]36[/TD]
[TD]1956050[/TD]
[TD]12/14/2018[/TD]
[TD]Jackets[/TD]
[/TR]
[TR]
[TD]37[/TD]
[TD]1956575[/TD]
[TD]5/28/2018[/TD]
[TD]Trousers[/TD]
[/TR]
[TR]
[TD]38[/TD]
[TD]1956575[/TD]
[TD]6/7/2018[/TD]
[TD]Underwear[/TD]
[/TR]
[TR]
[TD]39[/TD]
[TD]1956797[/TD]
[TD]3/1/2018[/TD]
[TD]Suits[/TD]
[/TR]
[TR]
[TD]40[/TD]
[TD]1959693[/TD]
[TD]12/23/2018[/TD]
[TD]Skirts[/TD]
[/TR]
[TR]
[TD]41[/TD]
[TD]1964578[/TD]
[TD]7/19/2018[/TD]
[TD]Parts[/TD]
[/TR]
[TR]
[TD]42[/TD]
[TD]1964578[/TD]
[TD]12/23/2018[/TD]
[TD]Shoes[/TD]
[/TR]
[TR]
[TD]43[/TD]
[TD]1978480[/TD]
[TD]10/15/2018[/TD]
[TD]Sweaters[/TD]
[/TR]
</tbody>[/TABLE]

Here's the partially working macro:

Sub Loop_vlookup_for_multiple_results()

Dim r As Long
Dim c As Long
Dim col_index As Long
Dim lastRow As Long

lastRow = Cells.Find(What:="*", After:=Range("a1"), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row

r = 2
col_index = 3

For c = 2 To lastRow

Cells(r, c).Value = Application.VLookup(Range("A2"), Range("A20:C43"), col_index, False)
col_index = col_index + 1
Next c

End Sub

Although developed and shown on the same worksheet for convenience, it will be preferable to have the data and search/output results on different tabs. It would also be nice to have the macro automatically create the "Order #" heading but it's not critical as I can do that manually. Thanks for any assistance and let me know if there are any questions.

Note: If I am way off base on my approach, please feel free to recommend a better methodology.

 

[DanteAmor]

Try this

Change data in red for your information

Sub Put_Order()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, r As Range, f As Range, j As Long, cell As String
     
    Set sh1 = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")  'sample
    Set sh2 = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]")  'Output
    
    sh2.Range("B:Z").ClearContents
    Set r = sh1.Range("A:A")
    For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
        Set f = r.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not f Is Nothing Then
            j = 2
            cell = f.Address
            Do
                sh2.Cells(1, j).Value = "Order " & j - 1
                sh2.Cells(c.Row, j).Value = f.Offset(0, 2).Value
                j = j + 1
                Set f = r.FindNext(f)
            Loop While Not f Is Nothing And f.Address <> cell
        End If
    Next
End Sub

 

[goobee]

Works like a charm. Thanks for the quick response and solution.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[goobee]

Just an update. While running the macro with actual data, I ran into a problem. If the Customer ID cell in the "Sample" sheet is blank, the macro errors out. I tried inserting

On Error Resume Next

but it just throws it into an endless loop. Is there a better error handler to get the macro to ignore/skip blank cells and move to the next record?

 

[DanteAmor]

Just an update. While running the macro with actual data, I ran into a problem. If the Customer ID cell in the "Sample" sheet is blank, the macro errors out. I tried inserting

On Error Resume Next

but it just throws it into an endless loop. Is there a better error handler to get the macro to ignore/skip blank cells and move to the next record?

You mean "output" sheet

It's your client ID, it should not be blank. Take care of your data

Try this

Sub Put_Order()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim c As Range, r As Range, f As Range, j As Long, cell As String
     
    Set sh1 = Sheets("Sheet1")  'sample
    Set sh2 = Sheets("Sheet2")  'Output
    
    sh2.Range("B:Z").ClearContents
    Set r = sh1.Range("A:A")
    For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
        [COLOR=#0000ff]if c.value <> "" then[/COLOR]
        Set f = r.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not f Is Nothing Then
            j = 2
            cell = f.Address
            Do
                sh2.Cells(1, j).Value = "Order " & j - 1
                sh2.Cells(c.Row, j).Value = f.Offset(0, 2).Value
                j = j + 1
                Set f = r.FindNext(f)
            Loop While Not f Is Nothing And f.Address <> cell
        End If
        [COLOR=#0000ff]end if[/COLOR]
    Next
End Sub

 

[goobee]

Thanks again, works like a charm. Sometimes, whether by system error or perhaps entry error, the Client ID is blank. It's a .csv export from the main database.

 

[DanteAmor]

Youre welcome & thanks for the feedback.