VBA Nested For Loop Efficiency - arrays

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 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.

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

Related

VBA stop using temporary ranges

I'm new to vba so I need some help making my macro more efficient. It does return the desired outcome however I know there must be a much quicker way to do so I just do not have the vba experience to know how.
I have a column which contains names of people assigned to a project. Some are only one name, and others may be multiple, for example:
At the moment, my code goes through this column, separates the names by comma, and enters them individually into a new range like so:
I then use a collection for the unique names and enter them in the final desired list. The names must show up three times, blank row, next three rows are the next name, so on.It should look like this in the end:
Currently my code is the following
Sub FindUniques()
Dim Ws As Worksheet, Ns As Worksheet
Dim SubString() As String, m As Integer, k As Long, NameCount As Integer
Dim allNames As New Collection, tempRng As Range
Set Ns = Worksheets("Sheet2")
Set Ws = Worksheets("Sheet1")
'Loops through the Assigned To column, separates and finds unique names
On Error Resume Next
For i = 1 To Ws.Range("A:A").End(xlDown).Row - Range("Assigned_to").Row
SubString = Split(Range("Assigned_to").Offset(i), ", ")
For j = 0 To UBound(SubString)
allNames.Add (allNames.count), SubString(j)
Next j
Next i
On Error GoTo 0
NameCount = allNames.count
For k = 1 To NameCount
For m = 1 To 4
Ns.Cells((k - 1) * 4 + m + 7, 2) = allNames.Key(k)
Next
Range("Names").Offset((k - 1) * 4).ClearContents
Next
End Sub
It works, however there must be some way that is more efficient than entering the names into a new range and then deleting the range. How can I use a collection or an array or something of the sort to make it quicker? Any ideas would be really appreciated
edit: I have now updated the code and it is using an collection, taking values from the substring. This enters the item (0, 1, 2, ...) in the cells instead of the keys (keys here are the names). How do I get it to return the key instead of the item number?
The slowest part of VBA are worksheet interactions so we should attempt to minimize that as much as possible.
Sub FindUniques()
Dim ws As Worksheet, ns As Worksheet
Dim splitStr() As String, nameStr As Variant
Dim dict As New Dictionary
Dim lastRow As Long, i As Long
Set ns = Worksheets("Sheet2")
Set ws = Worksheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
'Loops through the Assigned To column, separates and finds unique names
For i = 2 To lastRow
splitStr = Split(CStr(ws.Cells(i, 1).Value), ", ")
For Each nameStr In splitStr
If Not dict.Exists(nameStr) Then dict.Add nameStr , 0
Next
Next i
i = 2
For Each nameStr In dict.Keys
ns.Cells(i, 1).Resize(3).Value = nameStr
i = i + 4
Next
End Sub
Edited With #Toddleson & #BigBen 's suggestions
Good Luck!

how to populate and array with a loop

I have a strings in column "C", starting at C2 (for example: Cat, Dog, Bird, etc...) and I don't know how many. So I am using a LRow function to find the last row with data. Currently, the last row is C63 but this is expected to be different if I run the subroutine next week or next month (Hence why I said "I don't know how many"). I want to create an array for example RTArr = Array("Cat", "Dog", "Bird", etc...) So... I was thinking something like:
Dim RTArr As Variant
LRow = r.End(xlDown).Offset(x, y).Row
With ActiveSheet
For i = 2 To LRow
str = .Range("C" & i).Value
Next i
End With
Can I populate the array with something like:
Dim RTArr As Variant
LRow = r.End(xlDown).Offset(x, y).Row
With ActiveSheet
For i = 2 To LRow
ArrNum = (i - 1)
str = .Range("C" & i).Value
RTArr(ArrNum) = str
Next i
End With
Or does this not work because of the unknown size of the array? Or do I have to use "amend" in the loop? Would I be better off using a "collection" in this case? Or going about it some other way? Can I simply set a range of cells as an array without needing to loop?
If you declare a dynamic array at first (without the size), you need to ReDim it to the needed size before populating it, which in your case will be the number of rows e.g. ReDim RTArr(numberofitems). Or use a two dimensional array ReDim RTArr(numbercolumns, numberrows).
Remember that standard arrays begin at element 0, but you can define it however you like.
Remember that when inputting ranges into array Excel creates by default a two-dimensional array
More advanced techniques are possible of course, you can do some more research about VBA arrays regarding those:
1) you could ReDim the array after each element added inside of the loop, but this is mostly useful for one dimensional arrays.
2) you could define a much bigger size of array than needed before populating it, populate it, and then shrink the array to the actual size needed.
3) note that when using two (or more) dimensions ReDim Preserve works only on the last dimension.
Pseudo code for the basic populating:
Dim arr() as Variant
'we know we want to populate array with 10 elements
ReDim arr(1 to 10)
For i = 1 to 10
'This part will insert the count from the loop into the count position in array
' eg. first element of array will be a 1, second a 2 etc. until 10
arr(i) = i
Next i
If your version of Excel supports the TEXTJOIN function:
Sub Kolumn2Array()
Dim r As Range
Dim N As Long
Dim RTArray
Dim comma As String
comma = ","
N = Cells(Rows.Count, "C").End(xlUp).Row
Set r = Range("C2:C" & N)
With Application.WorksheetFunction
RTArray = Split(.TextJoin(comma, True, r), comma)
End With
End Sub

Create dynamically sized array to store row counter

The function below finds the first result.
There could be duplicate rows with matching values that meet my if statements. How would I create an array to store the row numbers the search function found so that I can process the data later.
How would I create the array size based on the number of results found in the for loop?
I am assuming that the for loop counter will have some sort of role to play in this. Let's say the for loop found 2 matches in row numbers 56 and 98 matching my if statements:
array_example(counter, 0) = 56
array_example(counter, 0) = 98
The stored values would be:
array_example(1, 0) = 56
array_example(2, 0) = 98
Private Sub Complex_Search(col1, cval1, col2, cval2)
'MsgBox (col1 & " " & col2)
'MsgBox (cval1 & " " & cval2)
Dim i
Dim lRow
Dim Counter
lRow = Cells(Rows.Count, 1).End(xlUp).row
Counter = 0
With Sheets("Office Spaces")
For i = 2 To lRow
If LCase(.Cells(i, col1).Value) = LCase(cval1) And LCase(.Cells(i, col2).Value) = LCase(cval2) Then
row = i
Counter = Counter + 1
End If
Next i
End With
If row = "" Then
MsgBox ("Search complete. 0 results found")
Else
GetRowData (row)
UserForm1.resmax.Value = 1
End If
End Sub
It's worth noting that you haven't even initialized row, and have just let vba implicitly declare it as a variant type for you. To avoid common problems that arise from typos, include Option Explicit at the top of your code and Dim every variable with the type beside it. For example: Dim i as long. Dim i will work, but it will declare it as a variant type
To initialize an array in VBA you use Dim row() as variant. From there you can re-dimension its size using Redim row(LboundX to UboundX) but this will reset all the stored values to zero. To get around this use Redim Preserve row(LBoundX to UBound X).
If you wish to use a 2D array, add a comma and then put the bounds for the next dimension Redim Preserve row(LBoundX to UBound X, LboundY to UBoundY)
At the top of your code I would include
Dim row() as Variant
Redim Preserve row(1 to 1)
Then within the loop I would change row = i to
row(Ubound(row)) = i
Redim Preserve row(1 to Ubound(row) +1)
Now that you have an array though, the check you do below will no longer work and will likely throw an error because you there's no specified index. Instead I suggest changing it from If row = "" Then to If Counter = 0 Then.
I'm not sure what the intention is with GetRowData(row) but you can just access each row number via row(i). It is worth noting however, that the row array will have Counter +1 number of items, but the last one will be blank. You could get around this by adding in an if statement within the already existing one that would look something like this:
If Counter = 0 Then
row(1) = i
Else
ReDim Preserve row(1 To UBound(row) + 1)
row(UBound(row)) = i
End If
Counter = Counter + 1
By implementing this change, row should have exactly Counter number of items that all have a non-empty value
I don't really suggest making a column array because it becomes more cumbersome to change the array size. Redim preserve or not only allows you to change the last dimension in the array, so to change the number of rows you would have to set the array equal to the transpose of itself, do the redim and then set it to the transpose of itself again. It's just needlessly messy. If you're pasting it to a sheet and need it to be in a column you could just transpose it at the end instead.

Writing into cells from array to range: array is not fully displayed in range

So I have an array with a lot of data, I used to write the data to excel sheet via for cycle, but it took too long, so I looked into faster alternatives.
Now I try to display the information with setting a value of range of cells directly to array:
Sub displayRandomMatrix(clientsColl As Collection, resultWorkbook As Workbook)
Dim NamesRange As Range
With resultWorkbook.Worksheets("matrix_random")
...
Set NamesRange = _
.Range(.Cells(2, 1), .Cells(clientsColl.Count + 1, 1))
Dim NamesArray() As String
ReDim NamesArray(1 To clientsColl.Count)
Dim clientRow As Long
Dim simulation As Long
clientRow = 1
simulation = 1
Dim clientCopy As client
For Each clientCopy In clientsColl
For simulation = 1 To clientCopy.getRandomNumbers.Count
...
Next
NamesArray(clientRow) = clientCopy.getClientName
clientRow = clientRow + 1
Next
...
NamesRange.value = NamesArray
...
End With
'debugging
Debug.Print "**************start"
For clientRow = 1 To clientsColl.Count
Debug.Print NamesArray(clientRow)
Next
Debug.Print "**************end"
End Sub
However when I then open a resultWorkbook I see that the same client's name is written in all the needed cells of the 1st column. At the same the debug section of the code produces correct output - there are correct multiple clients names in that array.
So something gets broken when I assign that array to a range: NamesRange.value = NamesArray.
At the same time I do similar thing with other arrays and it works, but this while comes out with the bug.
What might be the reason?
NOTE: clientsColl is a good, correct collection of Clients. There is nothing wrong with it, neither is with resultWorkbook.
NamesArray is a horizontal array, which you are trying to assign to a vertical range. Try using Application.Transpose
NamesRange.value = Application.Transpose(NamesArray)
Transpose is a quick fix but has its limitations. So if that does not work you will need to force a vertical array by declaring a 2nd dimension in your array:
ReDim NamesArray(1 To clientsColl.Count, 1 to 1)
Then when you fill it make sure to include the second dimension:
NamesArray(clientRow,1) = clientCopy.getClientName
Then you can assign it as you have:
NamesRange.value = NamesArray

Comparing two Arrays with excel VBA

As for the problem, I need to be able to compare all data in Variant array A to all data in Variant array B. I know I need some kind of double loop (so that every A value is checked against all B values), but I can't figure out how to do it. Here's what I have so far:
Sub Button_Click()
Dim trgtRange As Variant
Dim tempRange As Variant
Set myRange = ThisWorkbook.Sheets(1).Range("L:L")
For Each cell In myRange
If IsEmpty(cell) Then
ActiveCell.Offset(-1, 0).Select
currentRow = ActiveCell.Row
Set trgtRange = Range("L2:L" & currentRow)
Exit For
End If
Next cell
Set tempRange = Range("A1:A" & currentRow - 1)
' Insert a double loop here
End Sub
So, trgtRange is the Variant A and tempRange is Variant B. I know I could have set the Variant B up a little easier, but I already did it that way. After all, code should be polished as last operation anyway.
You might be wondering why Variants A and B are completely the same. Well, that's because I need to compare them so that I can find values that are close to each other, (i.e 10000 and 12000) and I need to incorporate some kind of tolerance for it.
Here is my answer. Why do you need two loops to do this. Some relative addressing handles this issue quite nicely. Set up a spreadsheet like this for an example:
and your code is simply this
Sub Button_Click()
Dim dblTolerance As Double
Dim tmp As Range
'Get source range
Set tmp = ActiveSheet.Range("A2")
'Get tolerance from sheet or change this to an assignment to hard code it
dblTolerance = ActiveSheet.Range("D13")
'use the temporary variable to cycle through the first array
Do Until tmp.Value = ""
'Use absolute function to determine if you are within tolerance and if so put match in the column
'NOTE: Adjust the column offset (set to 4 here) to match whichever column you want result in
If Abs(tmp.Value - tmp.Offset(0, 2).Value) < dblTolerance Then
tmp.Offset(0, 4).Value = "Match"
Else
tmp.Offset(0, 4).Value = "No Match"
End If
'Go to the next row
Set tmp = tmp.Offset(1, 0)
Loop
'Clean up
Set tmp = Nothing
End Sub
The comments in the code explain how it works. This is superior to a double loop because relative referencing is faster, the memory use is more efficient and you only have to make one pass at each row.
If you are required for some reason to use a double loop let me know, but that is inferior performance wise to this methodology. Hope this helps.

Resources