Multiple Criteria Evaluate Match Function Prohibitively Slow? - excel

Question

The following code successfully executes for small data sets:
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
However, for large data sets - such as 290,150 rows - the macro spins its wheels. It's known that Evaluate is expensive to run and I have tried running for sample sizes of 30 (success) and 1,000 (unsuccessful) and debugged carefully. Obviously in-cell array formulation drag-and-drop is not a practical alternative. So, the problem reduces to resolving endless spinning for the given multiple criteria match function required.
How do I bypass this constraint?

Answer 1

Try this approach using a dictionary as a lookup:
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

Stating Ranges instead of Columns and removing ReDim on loop helped.