许多迭代后，执行VBA代码变得缓慢 [英] Execution of VBA code gets slow after many iterations

问题描述

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

它的工作原理如预期的那样，但是像30.000迭代之后它变得更慢和更慢。在100.000迭代之后它真的很慢...

Sub检查每一行，如果它包含任何定义的单词（KeyWords Array）。如果是真的，它会检查它是否为假阳性，然后删除它。

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

感谢...

  Private Sub removeAllOthers（）
'
'删除名称不包含
'的所有行，LTG，Leitung ... 
'
 
 Application.ScreenUpdating = False 
 Dim TotalRows As Long 
 TotalRows = Cells（rows.Count，4）.End（xlUp）.row 
 
'定义所有含有Leitung的单词
 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，_ 
KUEH LLEITUNG，LUFTLEITUNG，DRUCKLEITUNG，HEIZUNGSLEITUNG，
OELLEITUNG，RUECKLAUFLEITUNG，HALTESCHIENE，$ 
SCHLAUCHLEITUNG，LUFTMASSE，KLEBEMASSE DICHTUNGSMASSE）
 
对于i = TotalRows要MIN_ROW步骤-1 
 
 Dim nmbr As Long 
 nmbr = TotalRows  -  i 
 
如果nmbr Mod 20 = 0然后
 Application.StatusBar =Progress：& nmbr& of& TotalRows  -  MIN_ROW& ：&格式（nmbr /（TotalRows  -  MIN_ROW），Percent）
如果
 
设置C =范围（NAME_COLUMN& i）
 
 Dim Val As Variant 
 Val = C.Value 
 
 Dim found As Boolean 
 
对于每个keyw在KeyWords中
 found = InStr（1，Val，keyw）< > 0 
如果（找到）然后
退出
结束如果
下一个
 
'检查LTG是否包含坏Word 
 Dim badWord As Boolean 
 
如果找到则
 
'必需，因为SCHALTER包含HALTER 
如果InStr（1，Val，SCHALTER）= 0然后
'坏字过滤器
对于每个badw在BadWords 
 badWord = InStr（1，Val，badw）<> 0 
如果badWord然后
退出
结束如果
下一个
 
结束如果
结束如果
 
如果found = False或badWord = True然后
 C.EntireRow.Delete 
结束如果
 
下一步i 
 
 Application.StatusBar = False 
 
 Application.ScreenUpdating = True 
 
 End Sub 
  

解决方案

与在内存中执行的循环相比，对长循环中的范围执行读/写操作的速度比较慢。

更有效的方法是加载范围进入存储器，在存储器（在数组级）上执行操作，清除整个范围的内容，并在工作表中立即显示新的结果（在数组上进行操作）（无常量读/写只读或写一次）。

下面你会发现一个200 000行的测试，说明了我的目标，我建议你检查一下。
如果你不是百分之百你正在寻找，你可以以任何你想要的方式进行调整。

我注意到屏幕在某一点变为空白;不要做任何事情，代码仍在运行，但您可能暂时被禁止使用Excel应用程序。

但您会注意到它更快。

  Sub Test（）
 
 Dim BadWords As Variant 
 Dim关键字作为变式
 
 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 
 
 
关键字= Array（LTG，LEITUNG，LETG，LEITG，MASSE）
 
 BadWords = Array（DUMMY BEF，HALTER，VORSCHALTGERAET，_ 
VORLAUFLEITUNG，ANLEITUNG，ABSCHIRMUNG，_ 
AUSGLEICHSLEITUNG，ABDECKUNG，KAELTEMITTELITITUNG b $ bLOESCHMITTELLEITUNG，ROHRLEITUNG，VERKLEIDUNG，_ 
UNTERDRUCK， ，LE LE UNG UNG UNG UNG UNG UNG，，，，，，，，，，，，，，，，，，，，， _ 
OELLEITUNG，RUECKLAUFLEITUNG，HALTESCHIENE，_ 
SCHLAUCHLEITUNG，LUFTMASSE，KLEBEMASSE，DICHTUNGSMASSE）
 
 
设置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 
 
对于lCnt = 1 To lRange_Row 
 Application.StatusBar = lCnt 
 
 val = vArray（lCnt，1 ）
 
对于每个键在关键字
 found = InStr（1，val，keyw）<> 0 
如果（找到）然后
退出
结束如果
下一个
 
如果发现然后
'因为SCHALTER包含HALTER 
如果InStr（1，val，SCHALTER）= 0然后
'坏Word过滤器
对于每个badw在BadWords 
 badWord = InStr（1，val，badw）<> ; 0 
如果badWord然后
退出
结束如果
下一个
结束如果
结束如果
 
如果found = False或badWord = True然后
 Else 
'将值加载到一个新数组
 lCnt_Final = lCnt_Final + 1 
 ReDim保存vArray_Final（1到lCnt_Final）
 vArray_Final（lCnt_Final）= vArray（lCnt，1）
 End If 
 
下一页lCnt 
 
 oRange.ClearContents 
 set oRange = nothing 
 
如果lCnt_Final<> 0然后
设置oRange = ThisWorkbook.Sheets（1）.Range（Cells（1，1），Cells（lCnt_Final，1））
 oRange = vArray_Final 
 End If 
 
 End Sub 
  

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

解决方案

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

这篇关于许多迭代后，执行VBA代码变得缓慢的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！