多次迭代后，VBA 代码的执行速度变慢

Question

我写了一个小子来过滤大约。 Excel 列表中有 56.000 个项目。

它按预期工作，但是在 30.000 次迭代之后它变得越来越慢。在 100.000 次迭代之后，它真的很慢......

Sub 检查每一行，如果它包含任何定义的单词（KeyWords 数组）。如果为真，则检查是否为误报，然后将其删除。

我在这里缺少什么？为什么会这么慢？

谢谢...

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

通常，与在内存中执行的循环相比，在长循环中对范围执行读取/写入操作会很慢。
一种更高效的方法是将范围加载到内存中，在内存中执行操作（在数组级别），清除整个范围的内容并在工作表中一次显示新结果（在对数组进行操作之后）（否常量读/写，但只读和写一次）。

您可以在下面找到一个包含 200 000 行的测试，该测试说明了我的目标，我建议您检查一下。 如果它不是您想要的 100%，您可以按照您希望的任何方式对其进行微调。
我注意到屏幕在某个时候变成了空白；不要执行任何操作，代码仍在运行，但您可能会暂时无法访问 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