0

私は約をフィルタリングするために小さなサブを書きました。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
4

1 に答える 1

0

通常、長いループ内の範囲に対する読み取り/書き込み操作の実行は、メモリ内で実行されるループと比較して低速です。
よりパフォーマンスの高いアプローチは、範囲をメモリにロードし、メモリ内で (配列レベルで) 操作を実行し、範囲全体の内容をクリアし、新しい結果を (配列での操作後に) シートに一度に表示することです (いいえ一定の読み取り/書き込みですが、読み取りと書き込みは 1 回のみ)。

以下に、私が何を目指しているかを示す 200,000 行のテストがあります。チェックすることをお勧めします。探していたものと完全に一致しない場合は、任意の方法で微調整できます。
ある時点で画面が空白になることに気付きました。何もしないでください。コードはまだ実行されていますが、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
于 2012-07-19T09:22:33.760 に答える