Why is multiple Application.VLookup into array dreadfully slow? - excel

Question

I have an external workbook from which I need to get data into my main workbook.
In the past i did this using A LOT of vlookups - and as a result the calculation was extremely slow. In order to speed things up, I have tried to convert the data from the external workbook into an array(arr2), and then doing the lookups into this. The result is that it's even more slow now..
The lookup value is composed of the values from two cells. I roughly have 1000 rows which, the way i do it, needs to be looped through in 44 columns. While it is actually working on a limited amount of rows, after one hour it is still processing when listing all 1000 rows.
What can be done to speed things up?
Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
Dim sup1 As Long, sup2 As Long, sup3 As Long, sup4 As Long, sup5 As Long, sup6 As Long, sup7 As Long,
sup8 As Long, sup9 As Long, sup10 As Long, sup11 As Long, sup12 As Long, sup13 As Long, sup14 As
Long, sup15 As Long
Dim i As Long, WS1 As Worksheet
Dim Book1 As Workbook, book2 As Workbook
Dim book2Name As String
book2Name = "SupportTables.xlsx"
Dim book2NamePath As String
book2NamePath = ThisWorkbook.Path & "\" & book2Name
Dim lastrow As Long
lastrow = Sheets("sheet1").Range("T" & Rows.Count).End(xlUp).Row
Set Book1 = ThisWorkbook
If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
Set book2 = Workbooks(book2Name)
Set WS1 = book2.Worksheets("pricediscinfo")
sup1 = Range("AN12")
sup2 = Range("AQ12")
...
sup15 = Range("CD12")
arr1 = Range("T15:T" & lastrow)
ReDim arr3(1 To UBound(arr1), 1 To 44)
arr2 = WS1.Range("a1").CurrentRegion.Value
For i = 1 To UBound(arr1)
arr3(i, 1) = Application.VLookup(arr1(i, 1) & sup1, arr2, 12, False)
arr3(i, 2) = Application.VLookup(arr1(i, 1) & sup1, arr2, 9, False)
...
arr3(i, 43) = Application.VLookup(arr1(i, 1) & sup15, arr2, 12, False)
arr3(i, 44) = Application.VLookup(arr1(i, 1) & sup15, arr2, 9, False)
Next i
Range("AN15:CE" & lastrow).Value = arr3
Any input appriciated!

Answer 1

Dictionaries are just a collection of key, value pairs like an 1 dimension array but with a string allowed as the key rather than just numbers. In this case because you want to look up 2 columns, the value that a key refers to I chose to be a 2 element array. For more complex cases you might just store the row number as the dictionary value and use it to get the value of any column on the lookup sheet (or array). See Dictionary Object
Update : (ws2.Cells(1, "I") corrected to (ws2.Cells(i, "I")
Option Explicit
Sub FasterLookUp()
Const WB2_NAME = "SupportTables.xlsx"
Const WS2_NAME = "pricediscinfo"
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim iLastrow As Long, i As Long
Dim arr1, arr2, arr3, sPath As String, s As String
Dim isOpen As Boolean, t0 As Single
Dim dict As Object, k
Set dict = CreateObject("Scripting.Dictionary")
Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Sheet1")
sPath = wb1.Path & "\"
' configuration
Dim sup(15) As String, supCol
supCol = Array("AN", "AQ", "AR", "AS", "AT", _
"AU", "AV", "AW", "AX", "AY", _
"AZ", "BA", "BB", "BC", "CD")
For i = 1 To 15
sup(i) = ws1.Cells(12, supCol(i - 1))
s = s & "sup(" & i & ") = " & sup(i) & vbCr
Next
MsgBox s ' for checking code
' open workbook if not already open
isOpen = False
For Each wb2 In Application.Workbooks
If wb2.Name = WB2_NAME Then
isOpen = True
Exit For
End If
Next
If isOpen = False Then
Set wb2 = Workbooks.Open(sPath & "\" & WB2_NAME, True, True) ' update links, read only
End If
Set ws2 = wb2.Sheets(WS2_NAME)
iLastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
' build dictionary as lookup table
t0 = Timer
For i = 1 To iLastrow
k = Trim(ws2.Cells(i, "A")) ' key
If Len(k) > 0 Then
If dict.exists(k) Then
MsgBox "Duplicate key " & k, vbCritical, "Row " & i
Exit Sub
Else
' col I and col L
dict.Add k, Array(ws2.Cells(i, "I"), ws2.Cells(i, "L")) ' lookups
End If
End If
Next
MsgBox dict.Count & " Items scanned into dictionary from " & ws2.Name, _
vbInformation, "Took " & Int(Timer - t0) & " seconds"
' update this workbook
t0 = Timer
iLastrow = ws1.Cells(Rows.Count, "T").End(xlUp).Row
arr1 = ws1.Range("T15:T" & iLastrow)
ReDim arr3(UBound(arr1), 1 To 44)
For i = 1 To UBound(arr1)
s = arr1(i, 1)
k = s & sup(1)
If dict.exists(k) Then
arr3(i, 1) = dict(k)(1) ' col L
arr3(i, 2) = dict(k)(0) ' col I
Else
'Debug.Print "No match '" & k & "'"
End If
''
k = s & sup(15)
If dict.exists(k) Then
arr3(i, 1) = dict(k)(1) ' col L
arr3(i, 2) = dict(k)(0) ' col I
Else
'Debug.Print "No match '" & k & "'"
End If
Next i
If isOpen = False Then wb2.Close False ' close if opened
ws1.Range("AN15:CE" & iLastrow).Value = arr3
MsgBox "Udate done", vbInformation, "Took " & Int(Timer - t0) & " seconds"
End Sub