Excel VBAパフォーマンス-100万行-値を含む行を1分未満で削除します

Question

私は1分以内に、大きなデータをフィルタリングしてワークシートの行を削除する方法を見つけようとしています

目標：

• 列1に特定のテキストを含むすべてのレコードを検索し、行全体を削除します
• すべてのセルの書式設定（色、フォント、境界線、列幅）と数式をそのまま保持する

。

テストデータ：

：

。

コードの仕組み：

1. すべてのExcel機能をオフにすることから始まります

2. ワークブックが空ではなく、削除するテキスト値が列1に存在する場合

   • 列1の使用範囲を配列にコピーします
   • 配列内のすべての値を逆方向に反復処理します

   • 一致が見つかった場合：

     • セルアドレスを_"A11,A275,A3900,..."_形式でtmp文字列に追加します
     • Tmp変数の長さが255文字に近い場合
     • .Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUpを使用して行を削除します
     • Tmpを空にリセットし、次の行セットに移動します
3. 最後に、すべてのExcel機能をオンに戻します

。

主な問題は削除操作であり、合計継続時間は1分未満でなければなりません。 1分未満で実行される限り、任意のコードベースのソリューションを使用できます。

これにより、スコープが受け入れ可能な回答が非常に少なくなります。すでに提供されている回答も非常に短く、実装が簡単です。 One 約30秒で操作を実行するため、受け入れ可能な解決策を提供する回答が少なくとも1つあります。

。

私の主な初期機能：

_Sub DeleteRowsWithValuesStrings()
    Const MAX_SZ As Byte = 240

    Dim i As Long, j As Long, t As Double, ws As Worksheet
    Dim memArr As Variant, max As Long, tmp As String

    Set ws = Worksheets(1)
    max = GetMaxCell(ws.UsedRange).Row
    FastWB True:    t = Timer

    With ws
        If max > 1 Then
            If IndexOfValInRowOrCol("Test String", , ws.UsedRange) > 0 Then
                memArr = .Range(.Cells(1, 1), .Cells(max, 1)).Value2
                For i = max To 1 Step -1

                    If memArr(i, 1) = "Test String" Then
                        tmp = tmp & "A" & i & ","
                        If Len(tmp) > MAX_SZ Then
                           .Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
                           tmp = vbNullString

                        End If
                    End If

                Next
                If Len(tmp) > 0 Then
                    .Range(Left(tmp, Len(tmp) - 1)).EntireRow.Delete Shift:=xlUp
                End If
                .Calculate
            End If
        End If
    End With
    FastWB False:   InputBox "Duration: ", "Duration", Timer - t
End Sub
_

---

ヘルパー関数（Excelの機能のオンとオフを切り替える）：

_Public Sub FastWB(Optional ByVal opt As Boolean = True)
    With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
    End With
    FastWS , opt
End Sub

Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
                  Optional ByVal opt As Boolean = True)
    If ws Is Nothing Then
        For Each ws In Application.ActiveWorkbook.Sheets
            EnableWS ws, opt
        Next
    Else
        EnableWS ws, opt
    End If
End Sub

Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
    With ws
        .DisplayPageBreaks = False
        .EnableCalculation = Not opt
        .EnableFormatConditionsCalculation = Not opt
        .EnablePivotTable = Not opt
    End With
End Sub
_

---

データを持つ最後のセルを検索します（@ZygDに感謝-現在、いくつかのシナリオでテストしました）。

_Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)

                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function
_

---

配列内の一致のインデックスを返します。一致が見つからない場合は0を返します。

_Public Function IndexOfValInRowOrCol( _
                                    ByVal searchVal As String, _
                                    Optional ByRef ws As Worksheet = Nothing, _
                                    Optional ByRef rng As Range = Nothing, _
                                    Optional ByRef vertical As Boolean = True, _
                                    Optional ByRef rowOrColNum As Long = 1 _
                                    ) As Long

    'Returns position in Row or Column, or 0 if no matches found

    Dim usedRng As Range, result As Variant, searchRow As Long, searchCol As Long

    result = CVErr(9999) '- generate custom error

    Set usedRng = GetUsedRng(ws, rng)
    If Not usedRng Is Nothing Then
        If rowOrColNum < 1 Then rowOrColNum = 1
        With Application
            If vertical Then
                result = .Match(searchVal, rng.Columns(rowOrColNum), 0)
            Else
                result = .Match(searchVal, rng.Rows(rowOrColNum), 0)
            End If
        End With
    End If
    If IsError(result) Then IndexOfValInRowOrCol = 0 Else IndexOfValInRowOrCol = result
End Function
_

。

更新：

テスト済みの6つのソリューション（それぞれ3つのテスト）：Excel Heroのソリューションが最速ですこれまで（式を削除）

。

最速から最遅までの結果を次に示します。

。

テスト1.合計100,000レコード、削除される10,000レコード：

_1. ExcelHero()                    - 1.5 seconds

2. DeleteRowsWithValuesNewSheet() - 2.4 seconds

3. DeleteRowsWithValuesStrings()  - 2.45 minutes
4. DeleteRowsWithValuesArray()    - 2.45 minutes
5. QuickAndEasy()                 - 3.25 minutes
6. DeleteRowsWithValuesUnion()    - Stopped after 5 minutes
_

。

テスト2.合計100万件のレコード、100,000件の削除対象：

_1. ExcelHero()                    - 16 seconds (average)

2. DeleteRowsWithValuesNewSheet() - 33 seconds (average)

3. DeleteRowsWithValuesStrings()  - 4 hrs 38 min (16701.375 sec)
4. DeleteRowsWithValuesArray()    - 4 hrs 37 min (16626.3051757813 sec)
5. QuickAndEasy()                 - 5 hrs 40 min (20434.2104492188 sec)
6. DeleteRowsWithValuesUnion()    - N/A
_

。

ノート：

1. ExcelHeroメソッド：実装が簡単で、信頼性が高く、非常に高速ですが、式は削除されます
2. NewSheetメソッド：実装が簡単で信頼性が高く、目標を達成
3. 文字列メソッド：実装の労力が増え、信頼性は高いが、要件を満たしていない
4. 配列メソッド：文字列に似ていますが、配列を再調整します（Unionの高速バージョン）
5. QuickAndEasy：実装は簡単（短く、信頼性が高く、エレガント）ですが、要件を満たしていません
6. 範囲連合：実装の複雑さは2および3と似ていますが、遅すぎます

また、異常な値を導入することで、テストデータをより現実的にしました。

• 空のセル、範囲、行、および列
• = [`〜！@＃$％^＆*（）_- + {} []\|;： '"、。<> /？などの特殊文字、個別および複数の組み合わせ
• 空白スペース、タブ、空の数式、境界線、フォント、およびその他のセルの書式設定
• 小数を含む大小の数値（= 12.9999999999999 + 0.00000000000000001）
• ハイパーリンク、条件付き書式設定ルール
• データ範囲内外の空のフォーマット
• データの問題を引き起こす可能性のあるその他のもの

Answer 1

参考として最初の回答を提供しています

他に利用可能なオプションがない場合は、他の人が便利だと思うかもしれません

• 結果を達成する最も速い方法は、削除操作を使用しないことです
• 100万件のレコードのうち、平均秒で100,000行を削除します

。

Sub DeleteRowsWithValuesNewSheet()  '100K records   10K to delete
                                    'Test 1:        2.40234375 sec
                                    'Test 2:        2.41796875 sec
                                    'Test 3:        2.40234375 sec
                                    '1M records     100K to delete
                                    'Test 1:        32.9140625 sec
                                    'Test 2:        33.1484375 sec
                                    'Test 3:        32.90625   sec
    Dim oldWs As Worksheet, newWs As Worksheet, rowHeights() As Long
    Dim wsName As String, t As Double, oldUsedRng As Range

    FastWB True:    t = Timer

    Set oldWs = Worksheets(1)
    wsName = oldWs.Name

    Set oldUsedRng = oldWs.Range("A1", GetMaxCell(oldWs.UsedRange))

    If oldUsedRng.Rows.Count > 1 Then                           'If sheet is not empty
        Set newWs = Sheets.Add(After:=oldWs)                    'Add new sheet
        With oldUsedRng
            .AutoFilter Field:=1, Criteria1:="<>Test String"
            .Copy                                               'Copy visible data
        End With
        With newWs.Cells
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteAll                            'Paste data on new sheet
            .Cells(1, 1).Select                                 'Deselect paste area
            .Cells(1, 1).Copy                                   'Clear Clipboard
        End With
        oldWs.Delete                                            'Delete old sheet
        newWs.Name = wsName
    End If
    FastWB False:   InputBox "Duration: ", "Duration", Timer - t
End Sub

。

高レベル：

• 新しいワークシートを作成し、初期シートへの参照を保持します
• 検索テキストの列1をオートフィルターします：.AutoFilter Field:=1, Criteria1:="<>Test String"
• 初期シートからすべての（可視）データをコピーします
• 列幅、フォーマット、およびデータを新しいシートに貼り付けます
• 初期シートを削除します
• 新しいシートの名前を古いシート名に変更します

質問に投稿された同じヘルパー関数を使用します

期間の99％はオートフィルターによって使用されます

。

これまでに見つけたいくつかの制限がありますが、最初の制限に対処できます。

1. 最初のシートに非表示の行がある場合、非表示になります

   • それらを隠すには別の関数が必要です
   • 実装によっては、期間が大幅に長くなる場合があります

2. VBA関連：

   • シートのコード名を変更します。 Sheet1を参照している他のVBAは壊れています（ある場合）
   • 最初のシート（存在する場合）に関連付けられているすべてのVBAコードを削除します

。

このような大きなファイルの使用に関する注意事項：

• バイナリ形式（.xlsb）は、ファイルサイズを劇的に削減します（137 Mbから43 Mbに）

• 管理されていない条件付き書式設定ルールは、パフォーマンスの指数関数的な問題を引き起こす可能性があります

  • コメント、データ検証でも同じ

• ネットワークからのファイルまたはデータの読み取りは、locallファイルでの作業よりもはるかに遅い

Answer 2

ソースデータに数式が含まれていない場合、またはシナリオで条件付き行の削除中に数式をハード値に変換できる場合（または必要な場合）、速度が大幅に向上します。

上記を警告として、私のソリューションは範囲オブジェクトのAdvancedFilterを使用します。 DeleteRowsWithValuesNewSheet（）の約2倍の速度です。

Public Sub ExcelHero()
    Dim t#, crit As Range, data As Range, ws As Worksheet
    Dim r&, fc As Range, lc As Range, fr1 As Range, fr2 As Range
    FastWB True
    t = Timer

        Set fc = ActiveSheet.UsedRange.Item(1)
        Set lc = GetMaxCell
        Set data = ActiveSheet.Range(fc, lc)
        Set ws = Sheets.Add
        With data
            Set fr1 = data.Worksheet.Range(fc, fc.Offset(, lc.Column))
            Set fr2 = ws.Range(ws.Cells(fc.Row, fc.Column), ws.Cells(fc.Row, lc.Column))
            With fr2
                fr1.Copy
                .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAll
                .Item(1).Select
            End With
            Set crit = .Resize(2, 1).Offset(, lc.Column + 1)
            crit = [{"Column 1";"<>Test String"}]
            .AdvancedFilter xlFilterCopy, crit, fr2
            .Worksheet.Delete
        End With

    FastWB False
    r = ws.UsedRange.Rows.Count
    Debug.Print "Rows: " & r & ", Duration: " & Timer - t & " seconds"
End Sub

Answer 3

私の年配のDell Inspiron 1564（Win 7 Office 2007）では次のようになります。

Sub QuickAndEasy()
    Dim rng As Range
    Set rng = Range("AA2:AA1000001")
    Range("AB1") = Now
    Application.ScreenUpdating = False
        With rng
            .Formula = "=If(A2=""Test String"",0/0,A2)"
            .Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
            .Clear
        End With
    Application.ScreenUpdating = True
    Range("AC1") = Now
End Sub

実行に約10秒かかりました。列[〜＃〜] aa [〜＃〜]が利用可能であると仮定しています。

編集＃1：

このコードはnot setCalculationをManualに設定することに注意してください。計算モードが手動に設定されている場合、パフォーマンスが向上しますafter「ヘルパー」列の計算が許可されます。

Answer 4

私はここで答えが信じられないほど遅れていることを知っていますが、将来の訪問者は非常に便利だと思うかもしれません。

注：私のアプローチでは、行のインデックス列が元の順序で終わる必要がありますが、行の順序が変わってもかまわない場合は、インデックス列は不要です。追加のコード行を削除できます。

私のアプローチ：私のアプローチは、選択した範囲（列）内のすべての行を選択し、Range.Sortを使用して昇順で並べ替え、選択した範囲（列内の"Test String"の最初と最後のインデックスを収集することでした）。次に、最初と最後のインデックスから範囲を作成し、Range.EntrieRow.Deleteを使用して、"Test String"を含むすべての行を削除します。

長所：
-猛烈な速さです。
-フォーマット、数式、チャート、写真、または新しいシートにコピーするメソッドのようなものは削除しません。

短所：
-実装するには適切なサイズのコードですが、それはすべて簡単です。

テスト範囲生成サブ：

Sub DevelopTest()
    Dim index As Long
    FastWB True
    ActiveSheet.UsedRange.Clear
    For index = 1 To 1000000 '1 million test
        ActiveSheet.Cells(index, 1).Value = index
        If (index Mod 10) = 0 Then
            ActiveSheet.Cells(index, 2).Value = "Test String"
        Else
            ActiveSheet.Cells(index, 2).Value = "Blah Blah Blah"
        End If
    Next index
    Application.StatusBar = ""
    FastWB False
End Sub

行のフィルターと削除：

Sub DeleteRowFast()
    Dim curWorksheet As Worksheet 'Current worksheet vairable

    Dim rangeSelection As Range   'Selected range
    Dim startBadVals As Long      'Start of the unwanted values
    Dim endBadVals As Long        'End of the unwanted values
    Dim strtTime As Double        'Timer variable
    Dim lastRow As Long           'Last Row variable
    Dim lastColumn As Long        'Last column variable
    Dim indexCell As Range        'Index range start
    Dim sortRange As Range        'The range which the sort is applied to
    Dim currRow As Range          'Current Row index for the for loop
    Dim cell As Range             'Current cell for use in the for loop

    On Error GoTo Err
        Set rangeSelection = Application.InputBox("Select the (N=) range to be checked", "Get Range", Type:=8)    'Get the desired range from the user
        Err.Clear

    M1 = MsgBox("This is recommended for large files (50,000 or more entries)", vbYesNo, "Enable Fast Workbook?") 'Prompt the user with an option to enable Fast Workbook, roughly 150% performace gains... Recommended for incredibly large files
    Select Case M1
        Case vbYes
            FastWB True  'Enable fast workbook
        Case vbNo
            FastWB False 'Disable fast workbook
    End Select

    strtTime = Timer     'Begin the timer

    Set curWorksheet = ActiveSheet
    lastRow = CLng(rangeSelection.SpecialCells(xlCellTypeLastCell).Row)
    lastColumn = curWorksheet.Cells(1, 16384).End(xlToLeft).Column

    Set indexCell = curWorksheet.Cells(1, 1)

    On Error Resume Next

    If rangeSelection.Rows.Count > 1 Then 'Check if there is anything to do

        lastVisRow = rangeSelection.Rows.Count

        Set sortRange = curWorksheet.Range(indexCell, curWorksheet.Cells(curWorksheet.Rows(lastRow).Row, 16384).End(xlToLeft)) 'Set the sort range

        sortRange.Sort Key1:=rangeSelection.Cells(1, 1), Order1:=xlAscending, Header:=xlNo 'Sort by values, lowest to highest

        startBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, MatchCase:=False).Row
        endBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row

        curWorksheet.Range(curWorksheet.Rows(startBadVals), curWorksheet.Rows(endBadVals)).EntireRow.Delete 'Delete uneeded rows, deleteing in continuous range blocks is quick than seperated or individual deletions.

        sortRange.Sort Key1:=indexCell, Order1:=xlAscending, Header:=xlNo 'Sort by index instead of values, lowest to highest
    End If

    Application.StatusBar = ""                    'Reset the status bar

    FastWB False                                  'Disable fast workbook

    MsgBox CStr(Round(Timer - strtTime, 2)) & "s" 'Display duration of task

Err:
    Exit Sub

End Sub

このコードはFastWB、FastWS AND EnableWS BY Paul Bicaを使用！

10万エントリの時間（10kが削除され、FastWB True）：
1。 0.2秒。
2。 0.2秒。
3。 0.21秒。
平均0.2秒。

100万エントリの時間（100kが削除され、FastWB True）：
1。 2.3秒。
2。 2.32秒。
3。 2.3秒。
平均2.31秒。

実行対象：Windows 10、iMac i3 11,2（2010年から）

[〜＃〜] edit [〜＃〜]
このコードは元々、数値範囲外の数値を除外する目的で設計されており、"Test String"を除外するように適合されているため、コードの一部が冗長になる場合があります。

Answer 5

使用範囲と行数の計算に配列を使用すると、パフォーマンスに影響する場合があります。次に、テストで1m以上のデータ行にわたって効率的であることが判明した別のアプローチを示します（25〜30秒）。フィルターを使用しないため、非表示であっても行を削除します。行全体を削除しても、他の残りの行の書式設定や列幅には影響しません。

1. 最初に、ActiveSheetに「テスト文字列」があるかどうかを確認します。列1のみに関心があるので、これを使用しました。

   _TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
   If TCount > 0 Then
   _

2. GetMaxCell（）関数を使用する代わりに、Cells.SpecialCells(xlCellTypeLastCell).Rowを使用して最後の行を取得しました。

   _EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
   _

3. 次に、データの行をループします。

   _While r <= EndRow
   _

4. 列1のセルが「テスト文字列」に等しいかどうかをテストするには：

   _If sht.Cells(r, 1).Text) = "Test String" Then
   _

5. 行を削除するには：

   _Rows(r).Delete Shift:=xlUp
   _

以下に完全なコードをまとめます。 ActiveSheetを変数Shtに設定し、ScreenUpdatingを有効にして、効率を改善しました。大量のデータなので、最後に変数をクリアするようにします。

_Sub RowDeleter()
    Dim sht As Worksheet
    Dim r As Long
    Dim EndRow As Long
    Dim TCount As Long
    Dim s As Date
    Dim e As Date

    Application.ScreenUpdating = True
    r = 2       'Initialise row number
    s = Now     'Start Time
    Set sht = ActiveSheet
    EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row

    'Check if "Test String" is found in Column 1
    TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
    If TCount > 0 Then

        'loop through to the End row
        While r <= EndRow
            If InStr(sht.Cells(r, 1).Text, "Test String") > 0 Then
                sht.Rows(r).Delete Shift:=xlUp
                r = r - 1
            End If
            r = r + 1
        Wend
    End If
    e = Now  'End Time
    D = (Hour(e) * 360 + Minute(e) * 60 + Second(e)) - (Hour(s) * 360 + Minute(s) * 60 + Second(s))
    Application.ScreenUpdating = True
    DurationTime = TimeSerial(0, 0, D)
    MsgBox Format(DurationTime, "hh:mm:ss")
End Sub
_