VBA vlookup multiple results

[dappy]

Hi folks,

Hopefully someone out there can help.

I have a list to vlookup which works (ish). the lookup only picks up the first instance of the source and not all instances.

source	requested	output
table-500227table--500227/line-110/output_2	500227​	table-500227table--500227/line-110/output_2
table-500227table--500227/line-120/output_2	500163​	table-500163table--500163/line-110/output_2
table-500227table--500227/line-130/output_2	500165​	table-500165table--500165/line-110/output_2
table-500163table--500163/line-110/output_2
table-500163table--500163/line-120/output_2
table-500163table--500163/line-130/output_2
table-500165table--500165/line-110/output_2
table-500165table--500165/line-120/output_2

the code i have that doesnt work completely

Dim Rw As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim WsF As Object
Set WsF = Application.WorksheetFunction


Set ws1 = ThisWorkbook.Sheets("dump")
Set ws2 = ThisWorkbook.Sheets("batch_list")
Set ws3 = ThisWorkbook.Sheets("output")

For Rw = 1 To 1000
On Error Resume Next
ws3.Cells(Rw, "A") = WsF.VLookup(ws2.Cells(Rw, "A"), ws1.Range("A1:b30000"), 2, False)
Next Rw

For Rw = 1 To 27
On Error Resume Next
ws3.Cells(Rw, "c") = WsF.VLookup(ws2.Cells(Rw, "A"), ws1.Range("d1:e30000"), 2, False)
Next Rw

any help or guidance much appreciated as normal
thanks in advance

 

[CsJHUN]

folks would it be cheeky of me to ask for further assistance?

the lookups i need are over a few columns, in in total. i've edited so i have 7 of the above code but its really slow to run. have i edited correctly? Here's the first 2 looking up columns B and E. is there anything i can do to make it all run faster? its looking up from 7000 rows.

Generaly looking good, but
a = 1 if there is no headline on 'dump'
b = 0 (at loop start) if no headline on 'batchlist'

These can make it run faster:
at the start of the code:

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

at the end of the code:

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Also, i will rewrite my code with changed viewpoint (not the req_id will be searched at the bump, but in reverse the bump will be searched in batchlsit).
Reporting back ASAP.

 

[CsJHUN]

Sorry for double post, cannot edit the previous one.

This made 100000 row in 10 sec

Sub Dappy_mrexcel()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'https://www.mrexcel.com/board/threads/vba-vlookup-multiple-results.1149524/
Dim request_cell As Variant
Dim search_cell As Variant
Set ws1 = ThisWorkbook.Sheets("dump")
Set ws2 = ThisWorkbook.Sheets("batchlist")
Set ws3 = ThisWorkbook.Sheets("output")
search_rows = ws1.Range("A" & Rows.Count).End(3).Row
request_rows = ws2.Range("a" & Rows.Count).End(3).Row

'req_id = ws2.Range("A" & b).Value
For A = 1 To search_rows
    search_id = Mid(ws1.Range("A" & A).Value, 7, 6)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("A" & i).Value = ws1.Range("A" & A).Value
        batch_row = 0
    End If
Next A
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[dappy]

thank you but i cant get this to work. i had to modify yours as its column B in ws1 i'm looking up and putting in Col A in ws3 but i cant get your latest one to give an output

 

[CsJHUN]

thank you but i cant get this to work. i had to modify yours as its column B in ws1 i'm looking up and putting in Col A in ws3 but i cant get your latest one to give an output

...
search_rows = ws1.Range("B" & Rows.Count).End(3).Row 'Modified ws1 range A to B, based on comment and based on this i think it will be the longest column, am i right?
request_rows = ws2.Range("a" & Rows.Count).End(3).Row

For A = 1 To search_rows
    search_id = Mid(ws1.Range("B" & A).Value, 7, 6) 'Modified ws1 range A to B
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("A" & i).Value = ws1.Range("B" & A).Value 'Modified ws1 range A to B
        batch_row = 0
    End If
Next A
...

This could be the 'loop'
Since your initial problem was the speed, try add the mentioned 4 "application...." rows to the begining and the end of the macro (outside of loops)

 

[dappy]

Hi again,

so code works super, thanks again, but its still slow, still somewhere around 1 second per row. anything I've done wrong? here's the whole code

Sub Dappy_latest_28102020()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Dim request_cell As Variant
Dim search_cell As Variant
Set ws1 = ThisWorkbook.Sheets("lookup_dump")
Set ws2 = ThisWorkbook.Sheets("batch_list")
Set ws3 = ThisWorkbook.Sheets("output")

    Sheets("output").Select
    Range("B2:B5000").Select
    Selection.ClearContents
     Range("e2:e5000").Select
    Selection.ClearContents
     Range("i2:i5000").Select
    Selection.ClearContents
     Range("l2:l5000").Select
    Selection.ClearContents
     Range("p2:p5000").Select
    Selection.ClearContents
     Range("t2:t5000").Select
    Selection.ClearContents
    Range("z2:z5000").Select
    Selection.ClearContents

request_rows = ws2.Range("a" & Rows.Count).End(3).Row
search_rows = ws1.Range("b" & Rows.Count).End(3).Row
i = 1
b = 1

For A = 1 To search_rows
    search_id = Mid(ws1.Range("b" & A).Value, 11, 12)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("b" & i).Value = ws1.Range("b" & A).Value
        batch_row = 0
    End If
Next A
request_rows = ws2.Range("a" & Rows.Count).End(3).Row
search_rows = ws1.Range("e" & Rows.Count).End(3).Row
i = 1
b = 1
For A = 1 To search_rows
    search_id = Mid(ws1.Range("e" & A).Value, 11, 12)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("e" & i).Value = ws1.Range("e" & A).Value
        batch_row = 0
    End If
Next A
request_rows = ws2.Range("a" & Rows.Count).End(3).Row
search_rows = ws1.Range("i" & Rows.Count).End(3).Row
i = 1
b = 1
For A = 1 To search_rows
    search_id = Mid(ws1.Range("i" & A).Value, 11, 12)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("i" & i).Value = ws1.Range("i" & A).Value
        batch_row = 0
    End If
Next A
request_rows = ws2.Range("a" & Rows.Count).End(3).Row
search_rows = ws1.Range("l" & Rows.Count).End(3).Row
i = 1
b = 1
For A = 1 To search_rows
    search_id = Mid(ws1.Range("l" & A).Value, 11, 12)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("l" & i).Value = ws1.Range("l" & A).Value
        batch_row = 0
    End If
Next A
request_rows = ws2.Range("a" & Rows.Count).End(3).Row
search_rows = ws1.Range("p" & Rows.Count).End(3).Row
i = 1
b = 1
For A = 1 To search_rows
    search_id = Mid(ws1.Range("p" & A).Value, 11, 12)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
   If batch_row > 0 Then
        i = i + 1
        ws3.Range("p" & i).Value = ws1.Range("p" & A).Value
        batch_row = 0
    End If
Next A
request_rows = ws2.Range("a" & Rows.Count).End(3).Row
search_rows = ws1.Range("t" & Rows.Count).End(3).Row
i = 1
b = 1
For A = 1 To search_rows
    search_id = Mid(ws1.Range("t" & A).Value, 11, 12)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("t" & i).Value = ws1.Range("t" & A).Value
        batch_row = 0
    End If
Next A
request_rows = ws2.Range("a" & Rows.Count).End(3).Row
search_rows = ws1.Range("z" & Rows.Count).End(3).Row
i = 1
b = 1
For A = 1 To search_rows
    search_id = Mid(ws1.Range("z" & A).Value, 11, 12)
    On Error Resume Next
    batch_row = ws2.Range("A1:A" & request_rows).Find(search_id, lookat:=xlWhole).Row
    If batch_row > 0 Then
        i = i + 1
        ws3.Range("z" & i).Value = ws1.Range("z" & A).Value
        batch_row = 0
    End If
Next A

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub