# VBA lookup to complete matrix

I have written the following the code to complete a matrix based on data provided in a second worksheet, but the code is really slow (note that s1=12,000, s2=40 and s3 = 200,000). Any suggestions on how to make this code faster?

Sub UpdateMatrix()

Dim wsOverview As Worksheet, wsData As Worksheet
Dim rngTable As Range
Dim varAccount As Variant, varData As Variant
Dim i As Long, t As Long

Set wsOverview = ThisWorkbook.Worksheets(1)
Set wsData = ThisWorkbook.Worksheets(2)

Set rngTable = wsOverview.Range("A:A")
i = Application.WorksheetFunction.CountA(rngTable) + 1

Set rngTable = wsData.Range("A:A")
t = Application.WorksheetFunction.CountA(rngTable)

For s1 = 2 To i
varAccount = wsOverview.Range("A" & s1).Value

For s2 = 1 To 37
varData = wsOverview.Range("A1").Offset(0, s2).Value

For s3 = 2 To t

If varAccount = wsData.Range("B" & s3).Value And varData = wsData.Range("A" & s3).Value Then

wsOverview.Range("A" & s1).Offset(0, s2).Value = wsData.Range("F" & s3).Value

Exit For

End If

Next s3

Next s2

Next s1

End Sub

• What do you mean s1=12000, s2=40, s3=200000 - are those the actual loop iterations rather than 3, 37, t? – Raystafarian Oct 20 '16 at 20:02
• You have nearly half a million lookups(40 x 12,000). Each looking down a dataset of 200k rows. I suggest you use binary lookups on the wsData. If the ranges cannot be sorted in the worksheet(because maybe they need to remain in default order, then you can make a copy of the original unsorted dataRange and write back afterwards. You can also use arrays and a binary array_lookup function, or the standard vlookup worksheetfunction with parameter set to true. – MacroMarc Oct 20 '16 at 21:50
• You already have 2 good reviews with great advice, but I want to personally attest that internalizing the matrix as an array and binary search will both make huge differences for your performance. I had a very reasonably performant disassembler in open office that started with a trace log of comparible size and added go-to and branch-not-taken disassembly, and it would hang forever if I tried to go row by row and in some cases use the sheet object at every data access. You are at the scale where both will make a huge improvement. – sqykly Oct 21 '16 at 2:34
• @sqykly is correct, simply pulling the information into an array rather than working on the sheet will make an incredible difference, even without any other changes. – Raystafarian Oct 22 '16 at 12:09
• Thanks for all of your help guys. I will look into feeding the data into arrays. – VBA Pete Oct 25 '16 at 15:22

I'm seeing several good practices in your code, you have a solid foundation to build upon. There are a few things to point out, but to answer your basic performance question -- process all your data in memory arrays. You'll see a tremendous performance improvement.

Several comments then, illustrated in the example code below:

1. Good declarations for your separate Worksheet variables; they are nicely descriptive.
2. Single-letter variables are not very descriptive (though a common practice is to restrict use of single-letter variables as loop indexes). So my suggestion is to rename these to ovRows and dataRows. These hold the number of rows detected on each sheet, so the variable name should echo that usage.
3. Use constants declared for fixed values. From what I can tell in your code, you have a limit to the number of columns on both sheets. Assuming this is a hard-coded value, declaring these as Const makes it easier to understand (and to change later if necessary).
4. Pull the overview and data ranges into local (memory-based) arrays for processing. This is the setup for the real speed.
5. Modify the loop to use the memory arrays. The example below is all-array, all the time. (If I've correctly understood your rows/columns logic.)
6. When the processing is completed, "write" the updated data back to the worksheet.

Thanks to @MacroMarc, I've updated the errors in my code (which was all done off the top of my head).

Option Explicit

Sub UpdateMatrix()
Dim wsOverview As Worksheet, wsData As Worksheet
Dim rngTable As Range

Set wsOverview = ThisWorkbook.Worksheets("Sheet1")
Set wsData = ThisWorkbook.Worksheets("Sheet2")

Dim ovRows As Long
Set rngTable = wsOverview.Range("A:A")
ovRows = Application.WorksheetFunction.CountA(rngTable) + 1

Dim dataRows As Long
Set rngTable = wsData.Range("A:A")
dataRows = Application.WorksheetFunction.CountA(rngTable)

'--- set up memory based arrays
Dim overviewRange as Range
Dim overview As Variant
Const OV_COL_LIMIT = 37
set overviewRange = wsOverview.Range("A1").Resize(ovRows, COL_LIMIT)
overview = overviewRange

Dim dataRange As Range
Dim data As Variant
Const DATA_COL_LIMIT = 6
set dataRange = wsData.Range("A1").Resize(dataRows, DATA_COL_LIMIT)
data = dataRange

Dim varAccount As Variant, varData As Variant
Dim dataAcct As Variant, dataData As Variant
For s1 = 2 To 3
varAccount = overview(s1, 1)
For s2 = 1 To COL_LIMIT
varData = overview(1, s2)
For s3 = 2 To dataRows
dataAcct = data(s3, 2)
If (varAccount = datraacct) And (varData = dataData) Then
overview(s1, 1) = data(s3, 6)
Exit For
End If
Next s3
Next s2
Next s1

'--- put the data array back on the sheet
overviewRange = overview
End Sub

• Thanks for your help PeterT. Your comments and code are much appriciated! I will review your code to get a grasp to get my array loops down. – VBA Pete Oct 25 '16 at 15:27

You have nearly half a million lookups(40 x 12,000). Each looking down a dataset of 200k rows. I suggest you use binary lookups on the wsData.

If the ranges cannot be sorted in the worksheet(because maybe they need to remain in default order, then you can make a copy of the original unsorted dataRange and write back afterwards.

.....
t = Application.WorksheetFunction.CountA(rngTable)
Dim dataRange As Range
Set dataRange = wsData.Range("A1:F" & t) 'whatever the entire dataset is
'Dim originalData as variant
'originalData = dataRange.value
dataRange.Sort Key1:=wsData.Range("B2"), Order1:=xlAscending, Key2:=wsData.Range("A2"), Order2:=xlAscending, _
Header:=xlYes 'sort the data so that binary Lookup can take place
Dim dataArr As Variant
dataArr = dataRange.Value

Dim overviewRange As Range
Set overviewRange = wsOverview.Range("A2:AN" & i) 'whatever the width and length of that range
Dim overviewArr As Variant
overviewArr = overviewRange.Value

headers = wsOverview.Range("B1:AN1").Value 'whatever the width of the headers that are gonna be varData assignments

Dim accountSpot As Long
Dim varData As Variant
Dim varAccount As Variant
dim stepper as long
For s1 = LBound(overviewArr) To UBound(overviewArr)
varAccount = overviewArr(s1, 1)
accountSpot = wsArrayBinaryLookup(varAccount, dataArr, 2, 1, True, True) 'get the first match of varAccount which we save for this iteration  for efficiency
'handle #NA errors
stepper = accountSpot 'for each varData we can search from the first match of varAccount in the sorted dataArray
Do While stepper <= UBound(dataArr) And dataArr(stepper, 2) = varAccount
If dataArr(stepper, 1) = varData Then
overviewArr(s1, s2 + 1) = dataArr(stepper, 6)
Exit Do
End If
stepper = stepper + 1
Loop
Next s2
Next s1
overviewRange = overviewArr
'dataRange = originalData
end sub


The wsArrayBinaryLookup functions:

  Public Function wsArrayBinaryLookup(ByVal val As Variant, arr() As Variant, ByVal searchCol As Long, ByVal returnCol As Long, Optional match As Boolean = True, Optional exactMatch As Boolean = True) As Variant

Dim a As Long, z As Long, curr As Long

wsArrayBinaryLookup = CVErr(xlErrNA)
a = LBound(arr)
z = UBound(arr)

If compare(arr(a, searchCol), val) = 1 Then
Exit Function
End If

If compare(arr(a, searchCol), val) = 0 Then
wsArrayBinaryLookup = IIf(match, a, arr(a, returnCol))
Exit Function
End If

If compare(arr(z, searchCol), val) = -1 Then
Exit Function
End If

While z - a > 1
curr = Round((CLng(a) + CLng(z)) / 2, 0)
If compare(arr(curr, searchCol), val) = 0 Then
z = curr
wsArrayBinaryLookup = IIf(match, curr, arr(curr, returnCol))
End If

If compare(arr(curr, searchCol), val) = -1 Then
a = curr
Else
z = curr
End If
Wend

If compare(arr(z, searchCol), val) = 0 Then
wsArrayBinaryLookup = IIf(match, z, arr(z, returnCol))
Else
If Not exactMatch Then
wsArrayBinaryLookup = IIf(match, a, arr(a, returnCol))
End If
End If

End Function

Public Function compare(ByVal x As Variant, ByVal y As Variant) As Long

If IsNumeric(x) And IsNumeric(y) Then
Select Case x - y
Case Is = 0
compare = 0
Case Is > 0
compare = 1
Case Is < 0
compare = -1
End Select
Else
If TypeName(x) = "String" And TypeName(y) = "String" Then
compare = StrComp(x, y, vbBinaryCompare) 'may wish to change this to vbTextCompare
End If
End If

End Function

• Thanks for the comment MacroMarc. Your answer works great, but I am struggling to follow what the code is doing. I guess, I am still to much of a VBA rookie :) – VBA Pete Oct 25 '16 at 15:29