Execution of VBA code gets slow after many iterations - performance

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

Answer 1

Typically, performing read from / write to operations on ranges in long loops are slow, compared to loops that are performed in memory.
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.
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.
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