VBA Macro to loop through Vlookup

goobee

New Member
Joined
Feb 25, 2011
Messages
26
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.

ABCDE
1Customer IDOrder 1Order 2Order 3
21918438JacketsTrousers
31920685Underwear
41920957SkirtsSuits
51925561Parts
61927037Sweaters
71928615Boots
81929262Coats
91930361Shorts
101932335SlippersDresses
111934871Waistcoats
121956050SocksHatsJackets
131956575TrousersUnderwearSuits
141956797Suits
151959693Skirts
161964578PartsShoes
171978480Sweaters

<tbody>
</tbody>

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

ABCD
19Customer IDOrder DateItem Ordered
2019184383/12/2018Jackets
2119184387/7/2018Trousers
2219206859/24/2018Underwear
2319209573/30/2018Skirts
2419209575/28/2018Suits
2519255617/5/2018Shoes
26192556110/23/2018Parts
27192703712/6/2018Sweaters
2819286151/9/2018Boots
2819292629/24/2018Coats
3019303619/24/2018Shorts
3119323356/7/2018Slippers
3219323357/8/2018Dresses
3319348716/7/2018Waistcoats
3419560502/19/2018Socks
3519560502/19/2018Hats
36195605012/14/2018Jackets
3719565755/28/2018Trousers
3819565756/7/2018Underwear
3919567973/1/2018Suits
40195969312/23/2018Skirts
4119645787/19/2018Parts
42196457812/23/2018Shoes
43197848010/15/2018Sweaters

<tbody>
</tbody>

Here's the partially working macro:

Code:
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.
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Try this

Change data in red for your information

Code:
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
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0
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

Code:
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?
 
Upvote 0
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

Code:
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
Code:
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
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,037
Members
448,543
Latest member
MartinLarkin

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