Question

我写了一个小子过滤约。 Excel列表中的56.000项。

它按预期工作，但在像30.000迭代之后变得非常慢和慢。经过100,000次迭代后，它真的很慢......

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

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

...谢谢

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

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

下面你会看到一个20万行的测试，说明了我的目标，我建议你看一下。如果它不是您所寻找的百分之百，您可以以任何您想要的方式对其进行微调我注意到屏幕在某一点变得空白;不执行任何操作，代码仍在运行，但您可能暂时被禁止使用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

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

1 个答案: