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

时间:2012-07-19 07:11:41

标签: performance excel vba iteration

我写了一个小子过滤约。 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

1 个答案:

答案 0 :(得分:0)

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

下面你会看到一个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