arrays - 使用字典的 Vlookup 替代方案

Question

下面的代码是 vlookup 的替代方法。
然后，此查找根据两个工作表的 A 列中的匹配值，即仅使用 1 个标准，将工作表“数据”的 D 列和 E 列的值复制到工作表“主”的 D 列和 E 列。
有人可以帮助如何使下面的代码查找和匹配 2 个条件，即查找和匹配两个工作表的 A 列和 B 列吗？
提前感谢您的帮助...

Option Explicit

Sub VLookup_Alternative()

Dim rng As Range, j As Range, i, lRow As Long, Dict As Object, myArray As Variant

    With Sheets("Data")
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        myArray = .Range("A1").Resize(lRow, 4)
        
        Set Dict = CreateObject("scripting.dictionary")
        Dict.CompareMode = vbTextCompare

        For i = 2 To UBound(myArray, 1)
        Dict(myArray(i, 1)) = i
        Next
        
    End With

    With Sheets("Master")
        Set rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
        
        For Each j In rng
            
            If Dict.exists(j.Value2) Then
                j.Offset(, 3) = myArray(Dict(j.Value2), 3)
                j.Offset(, 4) = myArray(Dict(j.Value2), 4)
            End If
        
        Next j
    
    End With

End Sub

Answer 1

请测试下一个更新版本(匹配 A 和 B 列的连接。使用数组根据字典项比较主表中的值会更快一点:

Sub VLookup_Alternative_match2Cols()
 Dim shD As Worksheet, shM As Worksheet, rng As Range, j As Range, i As Long
 Dim lRow As Long, Dict As Object, myArray, arrM

   Set shD = Sheets("Data")
   Set shM = Sheets("Master")
    With shD
        lRow = .cells(.rows.count, 1).End(xlUp).row
        myArray = .Range("A1").Resize(lRow, 5).Value2
        
        Set Dict = CreateObject("scripting.dictionary")
        Dict.CompareMode = vbTextCompare
        
        For i = 2 To UBound(myArray, 1)
            'to return the first occurrence in case of no unique keys:
            If Not Dict.Exists(myArray(i, 1) & myArray(i, 2)) Then
                Dict(myArray(i, 1) & myArray(i, 2)) = i
            End If
        Next
    End With

    With shM
        Set rng = .Range(.Range("A2"), .Range("A" & rows.count).End(xlUp).Offset(0, 4))
        arrM = rng.Value2 'place the range in an array for faster iteration
                          'and processing in memory
        Dim lastArrRow As Long: lastArrRow = UBound(myArray)
        For i = 1 To UBound(arrM)
            If Dict.Exists(arrM(i, 1) & arrM(i, 2)) Then
                arrM(i, 4) = myArray(Dict(arrM(i, 1) & arrM(i, 2)), 4)
                arrM(i, 5) = myArray(Dict(arrM(i, 1) & arrM(i, 2)), 5)
            Else        'return elements form the last row of myArray:
                arrM(i, 4) = myArray(lastArrRow, 4)
                arrM(i, 5) = myArray(lastArrRow, 5)
            End If
        Next i
    End With
    rng.value = arrM 'drop the processed array
    MsgBox "Ready..."
End Sub