9813

Execution of VBA code gets slow after many iterations

Question:

I have written a little sub to filter approx. 56.000 items in an Excel List.

It works as expected, but it gets really slower and slower after like 30.000 Iterations. After 100.000 Iterations it's really slow...

The Sub checks each row, if it contains any of the defined words (KeyWords Array). If true, it checks if it is a false positive and afterwards deletes it.

What am I missing here? Why does it get so slow?

Thanks...

Private Sub removeAllOthers() ' ' removes all Rows where Name does not contain ' LTG, Leitung... ' Application.ScreenUpdating = False Dim TotalRows As Long TotalRows = Cells(rows.Count, 4).End(xlUp).row ' Define all words with meaning "Leitung" KeyWords = Array("LTG", "LEITUNG", "LETG", "LEITG", "MASSE") ' Define all words which are false positives" BadWords = Array("DUMMY", "BEF", "HALTER", "VORSCHALTGERAET", _ "VORLAUFLEITUNG", "ANLEITUNG", "ABSCHIRMUNG", _ "AUSGLEICHSLEITUNG", "ABDECKUNG", "KAELTEMITTELLEITUNG", _ "LOESCHMITTELLEITUNG", "ROHRLEITUNG", "VERKLEIDUNG", _ "UNTERDRUCK", "ENTLUEFTUNGSLEITUNG", "KRAFTSTOFFLEITUNG", _ "KST", "AUSPUFF", "BREMSLEITUNG", "HYDRAULIKLEITUNG", _ "KUEHLLEITUNG", "LUFTLEITUNG", "DRUCKLEITUNG", "HEIZUNGSLEITUNG", _ "OELLEITUNG", "RUECKLAUFLEITUNG", "HALTESCHIENE", _ "SCHLAUCHLEITUNG", "LUFTMASSE", "KLEBEMASSE", "DICHTUNGSMASSE") For i = TotalRows To MIN_ROW Step -1 Dim nmbr As Long nmbr = TotalRows - i If nmbr Mod 20 = 0 Then Application.StatusBar = "Progress: " & nmbr & " of " & TotalRows - MIN_ROW & ": " & Format(nmbr / (TotalRows - MIN_ROW), "Percent") End If Set C = Range(NAME_COLUMN & i) Dim Val As Variant Val = C.Value Dim found As Boolean For Each keyw In KeyWords found = InStr(1, Val, keyw) <> 0 If (found) Then Exit For End If Next ' Check if LTG contains Bad Word Dim badWord As Boolean If found Then 'Necessary because SCHALTER contains HALTER If InStr(1, Val, "SCHALTER") = 0 Then 'Bad Word filter For Each badw In BadWords badWord = InStr(1, Val, badw) <> 0 If badWord Then Exit For End If Next End If End If If found = False Or badWord = True Then C.EntireRow.Delete End If Next i Application.StatusBar = False Application.ScreenUpdating = True End Sub

Answer1:

Typically, performing read from / write to operations on ranges in long loops are slow, compared to loops that are performed in memory.<br /> A more performant approach would be to load the range into memory, perform the operations in memory (on array level), clear the contents of the entire range and display the new result (after operations on the array) at once in the sheet (no constant Read / Write but only Read and Write a single time).

Below you find a test with 200 000 rows that illustrates what I aim at, I suggest you check it out. If it is not a hundred percent what you were looking for, you can finetune it in any way you wish.<br /> I noticed that the screen becomes blank at a certain point; don't do anything, the code is still running but you may be temporarily blocked out of the Excel application.<br /> However you'll notice that it is faster.

Sub Test() Dim BadWords As Variant Dim Keywords As Variant Dim oRange As Range Dim iRange_Col As Integer Dim lRange_Row As Long Dim vArray As Variant Dim lCnt As Long Dim lCnt_Final As Long Dim keyw As Variant Dim badw As Variant Dim val As String Dim found As Boolean Dim badWord As Boolean Dim vArray_Final() As Variant Keywords = Array("LTG", "LEITUNG", "LETG", "LEITG", "MASSE") BadWords = Array("DUMMY", "BEF", "HALTER", "VORSCHALTGERAET", _ "VORLAUFLEITUNG", "ANLEITUNG", "ABSCHIRMUNG", _ "AUSGLEICHSLEITUNG", "ABDECKUNG", "KAELTEMITTELLEITUNG", _ "LOESCHMITTELLEITUNG", "ROHRLEITUNG", "VERKLEIDUNG", _ "UNTERDRUCK", "ENTLUEFTUNGSLEITUNG", "KRAFTSTOFFLEITUNG", _ "KST", "AUSPUFF", "BREMSLEITUNG", "HYDRAULIKLEITUNG", _ "KUEHLLEITUNG", "LUFTLEITUNG", "DRUCKLEITUNG", "HEIZUNGSLEITUNG", _ "OELLEITUNG", "RUECKLAUFLEITUNG", "HALTESCHIENE", _ "SCHLAUCHLEITUNG", "LUFTMASSE", "KLEBEMASSE", "DICHTUNGSMASSE") Set oRange = ThisWorkbook.Sheets(1).Range("A1:A200000") iRange_Col = oRange.Columns.Count lRange_Row = oRange.Rows.Count ReDim vArray(1 To lRange_Row, 1 To iRange_Col) vArray = oRange For lCnt = 1 To lRange_Row Application.StatusBar = lCnt val = vArray(lCnt, 1) For Each keyw In Keywords found = InStr(1, val, keyw) <> 0 If (found) Then Exit For End If Next If found Then 'Necessary because SCHALTER contains HALTER If InStr(1, val, "SCHALTER") = 0 Then 'Bad Word filter For Each badw In BadWords badWord = InStr(1, val, badw) <> 0 If badWord Then Exit For End If Next End If End If If found = False Or badWord = True Then Else 'Load values into a new array lCnt_Final = lCnt_Final + 1 ReDim Preserve vArray_Final(1 To lCnt_Final) vArray_Final(lCnt_Final) = vArray(lCnt, 1) End If Next lCnt oRange.ClearContents set oRange = nothing If lCnt_Final <> 0 Then Set oRange = ThisWorkbook.Sheets(1).Range(Cells(1, 1), Cells(lCnt_Final, 1)) oRange = vArray_Final End If End Sub

Recommend