VBA Nested For Loop Efficiency

Question

I am trying to find the fastest way to perform a task in VBA. Currently I have it written as a nested for loop which can be extremely slow. I am looping over a list of unique numbers and matching them to numbers in a different list. If I get a match I store the information in a multidimensional array since there can be multiple matches and I want to keep track of all of them. Unfortunetly, this means when using a for loop if there are just 1000 unique numbers and 5000 numbers to look for matches my loop can end up iterating 1000*5000 = 5000000 times. As you see this can create a problem quickly. I am asking if there is any better way to approach this problem while staying in VBA. I already did all the tricks like set screenUpdating to false and calculation to manaul.

Here is my code:

For x = 0 To UBound(arrUniqueNumbers)
    Dim arrInfo() As Variant
    ReDim Preserve arrInfo(0)
    If UBound(arrInfo) = 0 Then
        arrInfo(0) = CStr(arrUniqueNumbers(x))
    End If

    For y = 2 To Length
        UniqueString = CStr(arrUniquePhoneNumbers(x))
        CLEARString = CStr(Sheets(2).Range("E" & y).Value)
        If UniqueString = CLEARString Then 'match!
            NormalizedDate = Format(CStr(Sheets(2).Range("G" & y).Value), "yyyymmdd")
            z = z + 1
            ReDim Preserve arrInfo(z)
            arrInfo(z) = NormalizedDate & " " & LTrim(CStr(Sheets(2).Range("D" & y).Value))
            arrInfo(z) = LTrim(arrInfo(z))
        End If
    Next

    arrUniqueNumbers(x) = arrInfo()
    ReDim arrInfo(0)  'erase everything in arrOwners
    z = 0
Next

Maybe using a Scripting.Dictionary is faster, since you will probably spend a lot of time in the Redim Preserve part of your code. — MP24
– MP24, Commented Jul 15, 2014 at 16:24

hnk · Accepted Answer · 2014-07-15 16:53:17Z

The loop is quite inefficient, so there are quite a few avoidable bottlenecks (mostly in the order of simplest to change to most complex to change)

Take the UniqueString step out of the innermost loop: This step doesn't change with changing y, so no point in repeating it.
Take the Redim Preserve out of the innermost loop: You are reallocating memory in the innermost loop which is extremely inefficient. Allocate 'sufficient' amount of memory outside the loop.
Do not keep using Sheets().Range() to access cell contents: Every time you access something on the spreadsheet, it is a HUGE drag and has a lot of overhead associated with the access. Consider one-step fetch operations from the spreadsheet, and one-step push operations back to the spreadsheet for your results. See sample code below.

Sample code for Efficient Fetch and Push-back operations for the spreadsheet:

Dim VarInput() As Variant
Dim Rng As Range

' Set Rng = whatever range you are looking at, say A1:A1000

VarInput = Rng
' This makes VarInput a 1 x 1000 array where VarInput(1,1) refers to the value in cell A1, etc.
' This is a ONE STEP fetch operation

' Your code goes here, loops and all

Dim OutputVar() as Variant
Redim OutputVar(1 to 1000, 1 to 1)

' Fill values in OutputVar(1,1), (1,2) etc. the way you would like in your output range

Dim OutputRng as Range
Set OutputRng = ActiveSheet.Range("B1:B1000")
' where you want your results

OutputRng = OutputVar
' ONE STEP push operation - pushes all the contents of the variant array onto the spreadsheet

There are quite a few other steps which can further dramatically speed up your code, but these should produce visible impact with not too much effort.

Siphor · Accepted Answer · 2014-07-15 17:05:05Z

dim dict as Object
set dict = CreateObject("Scripting.Dictionary")
dim x as Long
'Fill with ids
'Are arrUniqueNumbers and arrUniquePhoneNumbers the same?
For x = 0 To UBound(arrUniqueNumbers)
    dict.add CStr(arrUniquePhoneNumbers(x)), New Collection
next

'Load Range contents in 2-Dimensional Array
dim idArray as Variant
idArray = Sheets(2).Cells(2,"E").resize(Length-2+1).Value
dim timeArray as Variant
timeArray = Sheets(2).Cells(2,"G").resize(Length-2+1).Value
dim somethingArray as Variant
somethingArray = Sheets(2).Cells(2,"D").resize(Length-2+1).Value

dim y as Long
'Add Values to Dictionary
For y = 2 To Length
    Dim CLEARString As String
    CLEARString = CStr(timeArray(y,1))
    If dict.exists(CLEARString) then
        dict(CLEARString).Add LTrim( Format(timeArray(y,1)), "yyyymmdd")) _
                                & " " & LTrim(CStr(somethingArray(y,1)))
    end if
next

Access like this

dim currentId as Variant
for each currentId in dict.Keys
    dim currentValue as variant
    for each currentValue in dict(currentId)
        debug.Print currentId, currentValue
    next
next

Collectives™ on Stack Overflow

VBA Nested For Loop Efficiency

2 Answers 2

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related