Loop Referencing Sheet Gets Progressively Slower

[SomeKindaGreekGod]

I've had a very intriguing problem for a long time now, and am really hoping someone here can offer me some insight and hopefully a solution.

Here's the deal: I have a simple function that pulls in a single cell value, one per row, stores it in a property of a custom type, and then does a little more processing based on the value.

The custom type is GR, the property is CGID.

With Worksheets("Sheet1")
            GR.CGID = UCase$(Trim$(.Range("CGID")(rw).Text))
End With

It runs fine with no noticeable performance changes up to around 10,000 records, but beyond that, it gets progressively slower and slower and slower until, at about the 20,000 record mark, it's processing at about 1/10 the speed it started at! (100 recs/sec instead of 1000+)

For testing purposes, all the cell values are the same, and are a small string value.

I know that hitting the sheet from VBA is time-intensive itself, so of course it makes sense that if I had two calls to the sheet, it would take twice as long to run the function as if I have just one. But this issue where the processing speed decreases as time goes on leads me to think there's some kind of garbage collection or memory allocation problem that I hope can be solved.

So to all the other gurus out there, any ideas? Any help is much appreciated! I'm not looking for ways to speed up the code necessarily, I really just want it to go the same speed for all 20,000 records.

 

[chirp]

i was still pretty bothered by this problem and have been meaning to write a match function for a while so i came up with these two versions.

note that with the for-each loop there is a more constant time, than with referencing absolutely.

Option Explicit
Option Base 0

Public Const dupColorConst = 3


'highlights matches in a single column
Public Function highlight_Match(withinRange As Range, _
                                Optional excludeBlanks As Boolean = True, _
                                Optional matchCase As Boolean = True, _
                                Optional resetRangeColors As Boolean = True) As Boolean

Dim tDic As Object
Dim cnt As Long
Dim tStr As String
Dim withWS As Worksheet
Dim dupRange As Range, tCell As Range


On Error GoTo errHandle

With withinRange
    'checks and sets some initial parameters
    If withinRange Is Nothing Then Exit Function
    'get parent worksheet
    Set withWS = .Parent
    'sets range colors to 0 if told
    If resetRangeColors Then .Interior.ColorIndex = 0
End With


'resets range to used range, should use custom usedCol method
Set withinRange = Intersect(withinRange, withWS.UsedRange)

'sets dictionary
Set tDic = CreateObject("scripting.dictionary")
tDic.compareMode = BinaryCompare 'default, but faster than text compare, even with subbing ucase

'begins main loop
With withWS
    'loops through each cell in range
    For Each tCell In withinRange.Cells
        
        'matches case if told
        If matchCase Then
            tStr = Trim$(tCell.Text)
        Else: tStr = UCase$(Trim$(tCell.Text))
        End If
        
        'skip blanks if told
        If excludeBlanks Then
            If tStr = vbNullString Then GoTo skipCheck
        End If
        
        'checks if cell text exists in the dictionary
        If tDic.exists(tStr) Then
            If dupRange Is Nothing Then
                Set dupRange = Union(.Range(tDic.Item(tStr)), tCell)
                tDic.Item(tStr) = vbNullString
            Else
                If Not tDic.Item(tStr) = vbNullString Then
                    Set dupRange = Union(.Range(tDic.Item(tStr)), tCell, dupRange)
                    tDic.Item(tStr) = vbNullString
                Else
                    Set dupRange = Union(tCell, dupRange)
                End If
            End If
        Else
            tDic.Add tStr, tCell.Address
        End If
skipCheck:
        cnt = cnt + 1
        If cnt Mod 1000 = 0 Then
            Application.StatusBar = "Checking row: " & cnt
        End If
    Next
End With


If Not dupRange Is Nothing Then
    dupRange.Interior.ColorIndex = dupColorConst
End If

highlight_Match = True
errHandle:
    Set dupRange = Nothing
    Set withWS = Nothing
    Set tDic = Nothing
    Application.StatusBar = "Done."
End Function


'highlights matches in a single column
Public Function highlight_Match_Sorted(withinRange As Range, _
                                Optional excludeBlanks As Boolean = True, _
                                Optional matchCase As Boolean = False, _
                                Optional resetRangeColors As Boolean = True) As Boolean

Dim cnt As Long, i As Long
Dim tStr As String, nextStr As String
Dim withWS As Worksheet
Dim dupRange As Range, tCell As Range
Dim compMeth As VbCompareMethod

On Error GoTo errHandle

With withinRange
    'checks and sets some initial parameters
    If withinRange Is Nothing Then Exit Function
    'get parent worksheet
    Set withWS = .Parent
    'sets range colors to 0 if told
    If resetRangeColors Then .Interior.ColorIndex = 0
End With

'sets compare method
If matchCase Then
    compMeth = vbBinaryCompare
Else: compMeth = vbTextCompare
End If

'resets range to used range, should use custom usedCol method
Set withinRange = Intersect(withinRange, withWS.UsedRange)

'ensure sorted here use whatever sort you want
withinRange.Sort withinRange(1), xlAscending


With withWS
    'sets initial string to compare
    tStr = Trim$(withinRange(1).Text)
    
    'loops through each cell in range
    For Each tCell In withinRange.Cells
        'this is a poor way just to skip over any already matched duplicates
        If i > 0 Then
            i = i - 1
            GoTo skipCheck
        End If
        
        'sets next compare value
        nextStr = Trim$(tCell.offSet(1).Text)
        
        'skip blanks if told
        If excludeBlanks Then
            If tStr = vbNullString Then GoTo skipCheck
        End If
        
        'check next cell
        Do While StrComp(tStr, nextStr, compMeth) = 0
            i = i + 1
            nextStr = Trim$(tCell.offSet(i + 1).Text)
        Loop
        
        'sets range
        If i > 0 Then
            If dupRange Is Nothing Then
                Set dupRange = .Range(tCell, tCell.offSet(i))
            Else
                Set dupRange = Union(dupRange, .Range(tCell, tCell.offSet(i)))
            End If
        End If
        
skipCheck:
        'increment row counter
        cnt = cnt + 1
        'switch strings
        tStr = nextStr
        'update status bar
        If cnt Mod 1000 = 0 Then
            Application.StatusBar = "Checking row: " & cnt
        End If
    Next
End With

'updates color
If Not dupRange Is Nothing Then
    dupRange.Interior.ColorIndex = dupColorConst
End If

'sets return value of function
highlight_Match_Sorted = True

'no real error handling presently could add
errHandle:
    Set dupRange = Nothing
    Set withWS = Nothing
    Application.StatusBar = "Done."
End Function

 

[SomeKindaGreekGod]

So any idea how the performance of those compares to what you did earlier? I've switched to using a dictionary object in my code too, and performance is good now, but I still can't figure out what the .Text property's problem is.

On the MS thread, people suggest it has something to do with row height and/or how far away the viewing window is from the cell you're trying to get the Text property from, but I haven't been able to make that connection.

 

[Weaver]

Just wondering, is the numbferformat consistent for all the cells you're testing? If not, is it quicker to get the value and use =format()?

I'm guessing you probably already tried this, or your data isn't consistent enough.

 

[SomeKindaGreekGod]

It may be consistent for a column, but I can't say for sure. Say the user copies half their data from one source that has Excel formatting, then enters some by hand. I want to be sure I'm always getting what shows in the cell, because I've yet to have any user tell me they want the Value captured, regardless of the format (although that's the way it should be for good data)

Moreover, the format may be different on a per-user basis, my only restrictions are field length, so I can't enforce my own format, much as I've tried to get my users to always just format the cell as text and make sure that what shows there is what they want, people ignore instructions and continue to do it wrong, so I have to accommodate that so they don't have problems sending data.

 

[chirp]

I am not even sure if this is exactly what i thought it was as i had trouble replicating the results i got earlier on a different computer, and am not sure if i made a mistake somewhere.

In terms of performance the simple search and loop is faster than using a dictionary, the only benefit of the dictionary is that the data does not need to be sorted.

but try the function highlight_match_sorted in my earlier post, and compare it to what you get with a dictionary method as it should be quicker.

 

[SomeKindaGreekGod]

I'll give it a shot. But approx. 2 seconds for 20,000 records using the dictionary method is not bad at all in my opinion (granted that's on my laptop with a Core i5)

 

[FastExcel]

Fasinating problem. I posted an analysis with a bypass for the .Text slowdown and a comparison of .Text .Value and .Value 2 at
http://fastexcel.wordpress.com/2011/11/30/text-vs-value-vs-value2-slow-text-and-how-to-avoid-it/

 

[SomeKindaGreekGod]

I just wanted to praise Weaver again for turning me on to the Dictionary object. It has been an absolute lifesaver and I've already reused it several times. Just yesterday I was trying to solve a problem with a 2D array that would have up to 20,000 primary indexes, and it was also getting slower as the array filled up, took the function over a minute to run.

Switching to a dictionary of dictionaries has allowed me to cut the runtime to just 5 seconds!

Thanks!!

Sub checkDupes()
    startRow = 1
    lastRow = 42
    Set sd = CreateObject("scripting.dictionary")
    With Worksheets("sheet1")
        For rw = startRow To lastRow
            v = UCase$(Trim$(.Cells(rw, "C").Text))
            If sd.exists(v) Then
                'do whatever you need to do with duplicates
                .Cells(rw, "C").Interior.ColorIndex = 3
            Else
                sd.Add v, 1
            End If
        Next rw
    End With
End Sub

 

[Weaver]

I just wanted to praise Weaver again for turning me on to the Dictionary object. It has been an absolute lifesaver !!

I'd not heard of it myself until I stumbled across this board. What with that and regular expressions, I think I've become something of an evangelist!