Excel VBA Vlookup 多列

Question

我需要让这个宏更有效、更快速。我的解决方案非常非常慢。可以有超过 100k 行

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

我需要对两张工作表中的多列进行 vlookup。我所有的东西都只有一个标识符，我需要从另一张表中添加数据。

你能帮帮我吗？

Answer 1

使用 Application.Match 的 VBA 查找

• 这只是快了一步。
• 您查找了七次而不是每行一次。
• 使用 Application.Match，您可以获得行索引(如果不匹配，则会出现错误)，然后从该行 (sIndex) 中读取所有必要的单元格。<

快速修复

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