多個標准評估匹配 Function 速度太慢了？

Question

以下代碼對小型數據集成功執行：

Option Explicit
Option Base 1

Sub Left()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

        Dim ws1, _
            ws2 As Worksheet, _
            wb As Workbook
        
            Set wb = ThisWorkbook
            Set ws1 = wb.Worksheets("Adj")
            Set ws2 = wb.Worksheets("Deleted")
    
        Dim a, _
            b, _
            i, _
            j, _
            k As Long
            
            a = 957
            b = 290150
    
        Dim Item1, _
            Item2, _
            Arr() As Variant
    
        With ws2
            For i = 2 To a
                .Cells(i, 6) = Left(.Cells(i, 1), 11)
                .Cells(i, 7) = Right(.Cells(i, 1), 4)
            Next i
        End With
            
        With ws1
            For j = 2 To b
                ReDim Preserve Arr(j - 1)
                Item1 = Chr(34) & .Cells(j, 7) & Chr(34)
                Item2 = Chr(34) & .Cells(j, 9) & Chr(34)
                On Error Resume Next
                    k = Evaluate("=MATCH(1,('Deleted'!F:F = " & Item1 & ")*('Deleted'!G:G = " & Item2 & "),0)")
                    If Err.Number = 13 Then
                        Arr(j - 1) = ""
                        Else: Arr(j - 1) = k
                    End If
                On Error GoTo 0
            Next j
            .Range(.Cells(2, 15), .Cells(b, 15)) = WorksheetFunction.Transpose(Arr())
        End With
        
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

但是，對於大型數據集（例如 290,150 行），宏會旋轉它的輪子。 眾所周知， Evaluate運行起來很昂貴，我嘗試運行 30（成功）和 1,000（不成功）的樣本大小並仔細調試。 顯然，單元內陣列公式拖放不是一個實用的替代方案。 因此，問題減少到解決給定的多個標准匹配function 所需的無休止旋轉。

如何繞過這個約束？

Answer 1

使用字典作為查找嘗試這種方法：

Sub Left()

    Dim wsAdj As Worksheet, wsDel As Worksheet, wb As Workbook
    Dim lrDel As Long, lrAdj As Long, r As Long
    Dim dict, t, arr, arrG, arrI, arrRes, k
    
    Set wb = ThisWorkbook
    Set wsAdj = wb.Worksheets("Adj")
    Set wsDel = wb.Worksheets("Deleted")

    lrAdj = 290150
    lrDel = 957
    
    t = Timer
    
    'load a dictionary with lookup values constructed from wsDel ColA
    Set dict = CreateObject("scripting.dictionary")
    arr = wsDel.Range("A2:A" & lrDel).Value
    For r = 1 To UBound(arr, 1)
        k = Left(arr(r, 1), 11) & Chr(0) & Right(arr(r, 1), 4)
        dict(k) = r + 1 '+1 to adjust for starting at row 2
    Next r
    
    arrG = wsAdj.Range("G2:G" & lrAdj).Value    'get the match columns as arrays
    arrI = wsAdj.Range("I2:I" & lrAdj).Value
    ReDim arrRes(1 To UBound(arrG, 1), 1 To 1)  'resize the "result" array
    
    'loop the values from wsAdj
    For r = 1 To UBound(arrG, 1)
        k = arrG(r, 1) & Chr(0) & arrI(r, 1) 'build the "key"
        If dict.exists(k) Then
            arrRes(r, 1) = dict(k) 'get the matched row
        End If
    Next r
    
    wsAdj.Cells(2, 15).Resize(UBound(arrRes, 1), 1).Value = arrRes 'put the array on the sheet

    Debug.Print "done", Timer - t ' <1 sec
 
End Sub

Answer 2

說明范圍而不是列並在循環中刪除 ReDim 有幫助。