6
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ What do you mean s1=12000, s2=40, s3=200000 - are those the actual loop iterations rather than 3, 37, t? \$\endgroup\$ – Raystafarian Oct 20 '16 at 20:02
  • \$\begingroup\$ 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. \$\endgroup\$ – MacroMarc Oct 20 '16 at 21:50
  • \$\begingroup\$ 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. \$\endgroup\$ – sqykly Oct 21 '16 at 2:34
  • \$\begingroup\$ @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. \$\endgroup\$ – Raystafarian Oct 22 '16 at 12:09
  • \$\begingroup\$ Thanks for all of your help guys. I will look into feeding the data into arrays. \$\endgroup\$ – VBA Pete Oct 25 '16 at 15:22
4
\$\begingroup\$

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)
                dataData = data(s3, 1)
                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
\$\endgroup\$
  • \$\begingroup\$ 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. \$\endgroup\$ – VBA Pete Oct 25 '16 at 15:27
4
\$\begingroup\$

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

  Dim headers As Variant
  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
        For s2 = LBound(headers) To UBound(headers)
              varData = headers(1, s2)
              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
\$\endgroup\$
  • \$\begingroup\$ 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 :) \$\endgroup\$ – VBA Pete Oct 25 '16 at 15:29

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.