How to improve performance using dictionary? - vba

Question

I am using excel macro to validate data fields in a table. The data contains some fields that can contain one of the values listed in the dictionary.
When I tried to run the validation macro for 700,000 records, it literally gets stuck and takes a long time to complete. Can anyone help with improving the performance of this code?
The following is a sample code I am using for one of the fields to check the content of cells in a column against a list defined in the dictionary. This never completes when run over 700,000 column records, whereas takes around 30 seconds for 50,000 column records.
Sub Validate_Action_Type()
'Speed Up
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'Speed Up end
'Define the variables
Dim DicActionType As New Scripting.Dictionary
Dim CountActionTypeErrors As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
'Start the timer, used to calculate elapsed time
StartTime = Timer
'Create a dictionary of allowed marker type values
DicActionType.Add "Insert", 1
DicActionType.Add "Update", 2
DicActionType.Add "Delete", 3
'Check the Marker Type Column using the dictionery created
For Each d2 In Range(Range("C2"), Range("C2").End(xlDown))
If Not DicActionType.Exists(d2.Text) Then
d2.Interior.ColorIndex = 3
CountActionTypeErrors = CountActionTypeErrors + 1
Else
d2.Interior.ColorIndex = xlNone
End If
Next
'Calculate elapsed time
SecondsElapsed = Round(Timer - StartTime, 2)
'Pop-up the outcome message
MsgBox "Time taken in Seconds = " & SecondsElapsed _
& vbCrLf _
& "Total Errors = " & CountActionTypeErrors _
, , "Check Cells Highlighted RED"
'Restore state: undo the speed up settings
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState 'note this is a sheet-level setting
End Sub

Answer 1

Referencing cells is always very slow. As you want to color your cells, you need a reference, but only for coloring, not for checking. For checking you can use a much faster array.
In the following code I used an array to check the actions. On my machine its about 5 times faster having ~17% errors in my sample cells.
Sub Validate_Action_Type()
'Speed Up
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'Speed Up end
'Define the variables
Dim DicActionType As New Scripting.Dictionary
Dim CountActionTypeErrors As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim ActionArr, I As Integer
ActionArr = Range(Range("D2"), Range("C2").End(xlDown)).Value
'Start the timer, used to calculate elapsed time
StartTime = Timer
'Create a dictionary of allowed marker type values
DicActionType.Add "Insert", 1
DicActionType.Add "Update", 2
DicActionType.Add "Delete", 3
'Check the Marker Type Column using the dictionery created
Columns("C").Interior.ColorIndex = xlNone
For I = 1 To UBound(ActionArr)
If Not DicActionType.Exists(ActionArr(I, 1)) Then
'ActionArr(I, 2) = 3
Cells(I + 1, 3).Interior.ColorIndex = 3
CountActionTypeErrors = CountActionTypeErrors + 1
Else
ActionArr(I, 2) = 0
End If
Next I
'Calculate elapsed time
SecondsElapsed = Round(Timer - StartTime, 2)
'Pop-up the outcome message
MsgBox "Time taken in Seconds = " & SecondsElapsed _
& vbCrLf _
& "Total Errors = " & CountActionTypeErrors _
, , "Check Cells Highlighted RED"
'Restore state: undo the speed up settings
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState 'note this is a sheet-level setting
End Sub

Answer 2

As promised I have investigated what the time is going on my laptop. Without knowing which statements are the slowest, you can easily spend your time optimising sections of your code that have little effect on the duration. There is a lot of bad advice available based on people assumptions about what is slow. Application.ScreenUpdating = False will save very significant amounts of time. Other changes are often of little significance. It appears there is some significant overhead with calling WorksheetFunction from VBA because I have yet to find one that is faster than VBA. Unless someone says “I have run timings”, don’t believe them.
I will explain my implementation of your code and then tell you what I discovered. You will need to concatenate the blocks of code below if you wish to perform similar tests on your computer.
Option Explicit
Const ColCrnt As Long = 3
Const NumNames As Long = 30
Const RowDataFirst As Long = 2
Const RowMax As Long = 700000
Const ErrorMax As Long = 70000
I have used constants to specify values I might wish to vary between test runs.
I never changed ColCrnt from 3 (= C) or RowDataFirst from 2 since I do not believe their values are relevant.
I tried much lower values for RowMax and ErrorMax at first but most of my timings were with the values shown. My tests were with 10% errors. I am sure your data is much better so my timings for worksheet updates should be much worse than yours.
I have called the values you place in a dictionary, “names” or “valid names” so NumNamesis the constant I have changed the most.
Sub CtrlCheckAll()
Call CtrlCheck1
Call CtrlCheck1
Call CtrlCheck1
End Sub
I created three variations of your code. This routine allowed me to call all three in one go. It became clear that variations 2 and 3 were not significantly faster or slower than variation 1. In the end, I just used this routine to call variation 1 three times.
When you look at the timings, you will see how much variation there is from run to run. Most of this variation is probably background processes (task manager, virus checkers and the like). However, Excel also has background tasks (such as garbage collection). I prefer much longer test runs because they give more stable timings. Apart from increasing the number of rows, I am not sure how to slow your routine down; I have settled for running it several times and averaging their separate durations.
Sub CtrlCheck1()
Dim CountActionTypeErrors As Long
Dim d2 As Variant
Dim ExistsCrnt As Boolean
‘Dim InxVn As Long
Dim ValidNames As New Dictionary
Dim TimeCheckStart As Single
Dim TimeExistsTotal As Single
Dim TimeStart As Single
Dim TimeWshtTotal As Single
Dim Wsht As Worksheet
Set Wsht = Worksheets("Data")
TimeStart = Timer
Call GenDic(ValidNames, NumNames)
Debug.Print "Create time " & Format(Timer - TimeStart, "00.00000")
'TimeStart = Timer
'For InxVn = 0 To ValidNames.Count - 1
' Debug.Print ValidNames.Keys(InxVn)
'Next
'Debug.Print "Access time " & Format(Timer - TimeStart, "00.00000")
TimeStart = Timer
Call GenWsht(Wsht:=Wsht, RowDataFirst:=RowDataFirst, ColCrnt:=ColCrnt, _
RowMax:=RowMax + RowDataFirst - 1, _
ErrorMax:=ErrorMax, Dic:=ValidNames)
Debug.Print "Build worksheet time " & Format(Timer - TimeStart, "00.000")
Application.ScreenUpdating = False
TimeExistsTotal = 0!
TimeWshtTotal = 0!
TimeCheckStart = Timer
You will recognise some of the variables while others have been introduced by me.
Your code accesses the active worksheet. This relies on the user having the correct worksheet active when the macro is started. You would not do this if you had ever had to fix the mess caused by a user running a macro against the wrong worksheet and not having a backup of the undamaged worksheet. Being explicit about the worksheet to be accessed makes your code clearer, reduces the opportunities for disaster and has no noticeable time penalty.
I have not given you the code for GenDic since you have your own real data. However, I will add the code if you want it. Notice, I have placed Timer around this call. I wanted to know if creating a dictionary was slow process. I discovered the duration was less than Timer can accurately record. Normally the duration was given as zero thousandths of a second although occasionally it was four thousandths of a second
I have commented out the code to list the keys in the dictionary because it was creating too many lines. Again my motive was to see if accessing keys was slow but again the duration was less than Timer can accurately record.
I have not given you the code for GenWsht since you have your own real data. Again, I will add the code if you want it.
The last three statements of the above block are the important ones. TimeCheckStart is used to calculate the total duration of the main block of code. TimeExistsTotal and TimeWshtTotalare used to accumulate the duration of the two statements of thought might be the most expensive in terms of time. I will explain them later.
With Wsht
For Each d2 In Range(.Cells(RowDataFirst, ColCrnt), _
.Cells(RowDataFirst, ColCrnt).End(xlDown))
TimeStart = Timer
ExistsCrnt = ValidNames.Exists(d2.Text)
TimeExistsTotal = TimeExistsTotal + Timer - TimeStart
If Not ExistsCrnt Then
TimeStart = Timer
d2.Interior.ColorIndex = 3
TimeWshtTotal = TimeWshtTotal + Timer - TimeStart
CountActionTypeErrors = CountActionTypeErrors + 1
End If
Next
End With
This is a slightly modified version of the critical part of your code. As explained earlier, I access cells in a named worksheet. I do not believe this could have a noticeable
I have split the test for a name existing out of the If statement so I can place Timer statements around the test. This probably has a minor effect on the duration but you cannot add timer statements without having an effect. Note that what these Timer statements are doing is accumulating the total duration of these tests. I have also places Timer statements around d2.Interior.ColorIndex = 3
Debug.Print "##### Check 1 #####"
Debug.Print " Number rows " & RowMax
Debug.Print " Number errors " & ErrorMax
Debug.Print " Valid names " & ValidNames.Count
Debug.Print " Total check time " & Format(Timer - TimeCheckStart, "00.000")
Debug.Print "Total exists time " & Format(TimeExistsTotal, "00.000")
Debug.Print " Total wsht time " & Format(TimeWshtTotal, "00.000")
End Sub
This is the final block of variation 1 of my code.
Two of my timings were:
Total check time 12.766 9.820
Total exists time 10.031 7.852
Total wsht time 2.152 1.543
The first issue to notice is the difference between the two sets of figures with the first run taking 33% more time than the second. This is typical of the variation you will get in the duration of short runs.
The second issue is that the total duration of the two timed statements is around .6 seconds less that the total duration. This is to be expected since all the other statement take some time; there is no expensive statement yet to find. Since your durations are so much longer than mine, you need to review your timings and perhaps test other statements if your unexplained duration is excessive.
The last issue is that the total duration of the worksheet update is so much less that the existence check. Since 10% of my data is faulty which I assume far exceeds your error rate, your worksheet update time should be much, much less than mine. Optimising the worksheet update would have minimal effect on the total duration.
With variation 2, the inner code is:
RowLast = .Cells(Rows.Count, ColCrnt).End(xlUp).Row
For RowCrnt = RowDataFirst To RowLast
TimeStart = Timer
ExistsCrnt = ValidNames.Exists(.Cells(RowCrnt, ColCrnt).Text)
TimeExistsTotal = TimeExistsTotal + Timer - TimeStart
If Not ExistsCrnt Then
TimeStart = Timer
.Cells(RowCrnt, ColCrnt).Interior.ColorIndex = 3
TimeWshtTotal = TimeWshtTotal + Timer - TimeStart
CountActionTypeErrors = CountActionTypeErrors + 1
End If
Next
Here I have used a For Loop instead of a For Each Loop. It is not clear from my timings which is faster. I will not bother to test further. I would use whichever I found more convenient even if I knew one was fractionally faster than the other.
For variation 3, I introduced a With statement for the cell:
With Wsht
RowLast = .Cells(Rows.Count, ColCrnt).End(xlUp).Row
For RowCrnt = RowDataFirst To RowLast
With .Cells(RowCrnt, ColCrnt)
TimeStart = Timer
ExistsCrnt = ValidNames.Exists(.Text)
TimeExistsTotal = TimeExistsTotal + Timer - TimeStart
If Not ExistsCrnt Then
TimeStart = Timer
.Interior.ColorIndex = 3
TimeWshtTotal = TimeWshtTotal + Timer - TimeStart
CountActionTypeErrors = CountActionTypeErrors + 1
End If
End With
Next
End With
This does look to be faster than variation 2, as expected, and perhaps a little faster than variation 1 but the evidence for these conclusions is poor.
Here are the timings:
In the bold lines, the timings are averages of the individual run times shown below.
The big reveal from this is that the size of the dictionary has no effect on run time.
My investigation has revealed nothing that would help you. I have explained how I created my timings and how I interpreted those timings so you can test what is different about your system.