經過多次迭代後，VBA代碼的執行速度變慢了

Question

我已經寫了一個小小的過濾器， Excel列表中的56.000項。

它按預期工作，但在30,000次迭代之後變得更慢更慢。 100.000次迭代後，它真的很慢...

如果Sub包含任何已定義的字（KeyWords Array），它會檢查每一行。如果屬實，則檢查它是否爲假陽性，然後將其刪除。

我在這裏錯過了什麼？爲什麼它變得如此緩慢？

謝謝...

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

通常情況下，執行從讀/寫在長期循環範圍的操作速度很慢，比在內存進行循環。
更高效的方法是將範圍加載到內存中，在內存中執行操作（在數組級別上），清除整個範圍的內容並在表單中一次顯示新結果（在對陣列進行操作之後） （沒有恆定的讀/寫，但只能讀和寫一次）。

下面你會發現一個測試200000行，說明我的目標，我建議你檢查一下。 如果它不是百分之百你正在尋找，你可以以任何你想要的方式微調它。
我注意到屏幕在某個點變爲空白;不要做任何事情，代碼仍在運行，但您可能暫時被阻止在Excel應用程序之外。
但是您會注意到速度更快。

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