Excel VBA Vlookup multiple Columns

Question

i need make this macro more effective and faster. My solution is very, very slow. There can be over 100k rows

Sub VlookupPOR()


Dim PorWs As Worksheet, InDataBodyWs As Worksheet
Dim PorLastRow As Long, InDataBodyLastRow As Long, x As Long
Dim dataRng As Range


Set PorWs = ThisWorkbook.Worksheets("POR")
Set InDataBodyWs = ThisWorkbook.Worksheets("InDataBody")


PorLastRow = PorWs.Range("A" & Rows.Count).End(xlUp).Row
InDataBodyLastRow = InDataBodyWs.Range("H" & Rows.Count).End(xlUp).Row


Set dataRng = InDataBodyWs.Range("H4:AR" & InDataBodyLastRow)


For x = 2 To PorLastRow

    On Error Resume Next
    PorWs.Range("L" & x).Value = Application.WorksheetFunction.VLookup( _
    PorWs.Range("G" & x).Value, dataRng, 5, False) 'LastName
    
    PorWs.Range("N" & x).Value = Application.WorksheetFunction.VLookup( _
    PorWs.Range("G" & x).Value, dataRng, 7, False) 'FirstName
    
    PorWs.Range("O" & x).Value = Application.WorksheetFunction.VLookup( _
    PorWs.Range("G" & x).Value, dataRng, 2, False) 'BirthNumber

    PorWs.Range("K" & x).Value = Application.WorksheetFunction.VLookup( _
    PorWs.Range("G" & x).Value, dataRng, 4, False) 'NativeLastName

    PorWs.Range("J" & x).Value = Application.WorksheetFunction.VLookup( _
    PorWs.Range("G" & x).Value, dataRng, 16, False) 'legalPersonName
    
    PorWs.Range("H" & x).Value = Application.WorksheetFunction.VLookup( _
    PorWs.Range("G" & x).Value, dataRng, 18, False) 'legalPersonBusinessId
    
    PorWs.Range("I" & x).Value = Application.WorksheetFunction.VLookup( _
    PorWs.Range("G" & x).Value, dataRng, 24, False) 'legalPersonBusinessId
    
    
Next x


End Sub

I need a vlookup for multiple columns from two sheets. I have only one identifier for everything and I need to add data from another sheet.

Can you help me?

Answer 1

VBA Lookup Using Application.Match

• This is only a step faster.
• You were looking up seven times instead of once per row.
• With Application.Match you get the row index (or an error if no match) and then read all the necessary cells from this row ( sIndex ).

A Quick Fix

Sub LookupPOR()
    
    ' Source
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("InDataBody")
    Dim slRow As Long: slRow = sws.Range("H" & sws.Rows.Count).End(xlUp).Row
    Dim srg As Range: Set srg = sws.Range("H4:AR" & slRow)
    Dim scrg As Range: Set scrg = srg.Columns(1)
    
    ' Destination
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("POR")
    Dim dlRow As Long: dlRow = dws.Range("A" & dws.Rows.Count).End(xlUp).Row
    
    Dim dValue As Variant
    Dim sIndex As Variant
    Dim r As Long
    
    For r = 2 To dlRow
        dValue = dws.Cells(r, "G").Value
        If Not IsError(dValue) Then
            If Len(dValue) > 0 Then
                sIndex = Application.Match(dValue, scrg, 0)
                If IsNumeric(sIndex) Then
                    ' legalPersonBusinessId - "Y"
                    dws.Cells(r, "H").Value = srg.Cells(sIndex, 18).Value
                    ' legalPersonBusinessId - "AE"
                    dws.Cells(r, "I").Value = srg.Cells(sIndex, 24).Value
                    ' legalPersonName - "W"
                    dws.Cells(r, "J").Value = srg.Cells(sIndex, 16).Value
                    ' NativeLastName - "K"
                    dws.Cells(r, "K").Value = srg.Cells(sIndex, 4).Value
                    ' LastName - "L"
                    dws.Cells(r, "L").Value = srg.Cells(sIndex, 5).Value
                    ' FirstName - "N"
                    dws.Cells(r, "N").Value = srg.Cells(sIndex, 7).Value
                    ' BirthNumber - "I"
                    dws.Cells(r, "O").Value = srg.Cells(sIndex, 2).Value
                End If
            End If
        End If
    Next r
 
    MsgBox "Lookup complete.", vbInformation

End Sub