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
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
UniqueStringstep out of the innermost loop: This step doesn’t change with changing
y, so no point in repeating it.
- Take the
Redim Preserveout 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.
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