1分以内に大量のデータをフィルタリングし、ワークシート内の行を削除する方法を探しています
目標:
- 列1に特定のテキストを含むすべてのレコードを検索し、行全体を削除します。
- すべてのセルの書式設定(色、フォント、境界線、列幅)と数式をそのまま維持します
。
テストデータ:
:
。
コードの動作方法:
- まずExcelのすべての機能をオフにします
ワークブックが空でなく、削除するテキスト値が列1に存在する場合
- 列1の使用範囲を配列にコピーします
- 配列内のすべての値を逆順に反復処理します
一致が見つかった場合:
- セルアドレスをtmp文字列に次の形式で追加します。
"A11,A275,A3900,..."
- tmp変数の長さが255文字に近い場合
- 行を削除する
.Range("A11,A275,A3900,...").EntireRow.Delete Shift:=xlUp
- tmp を空にリセットし、次の行セットに進みます。
- セルアドレスをtmp文字列に次の形式で追加します。
- 最後に、Excelのすべての機能をオンに戻します。
。
主な問題は削除操作です、合計実行時間は 1 分未満である必要があります。1 分未満で実行される限り、任意のコードベースのソリューションが受け入れられます。
これにより、受け入れ可能な回答の範囲が非常に狭まります。すでに提供されている回答も非常に短く、実装も簡単です。1つ約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
。
ノート:
- ExcelHeroメソッド:実装が簡単、信頼性が高く、非常に高速ですが、数式が削除されます
- NewSheet方式: 実装が簡単で信頼性が高く、目標を達成します
- 文字列メソッド: 実装に手間がかかるが、信頼性は高いが、要件を満たさない
- 配列メソッド: 文字列に似ていますが、配列を ReDim します (Union の高速バージョン)
- QuickAndEasy: 実装が簡単 (短く、信頼性が高く、エレガント) だが、要件を満たしていない
- 範囲結合: 実装の複雑さは 2 と 3 と同等ですが、遅すぎます
また、異常な値を導入することで、テスト データをより現実的なものにしました。
- 空のセル、範囲、行、列
- 特殊文字、例えば =[`~!@#$%^&*()_-+{}[]\|;:'",.<>/?、個別の文字および複数の文字の組み合わせ
- 空白、タブ、空の数式、境界線、フォント、その他のセルの書式設定
- 小数点付きの大きい数字と小さい数字 (=12.9999999999999 + 0.000000000000000001)
- ハイパーリンク、条件付き書式ルール
- データ範囲の内外の空の書式
- データの問題を引き起こす可能性のあるその他のもの
ベストアンサー1
最初の回答は参考として提示します
他に選択肢がない場合、他の人にとっては役立つかもしれない
- 結果を得るための最も早い方法は、削除操作を使用しないことです。
- 100万件のレコードから平均10万行を削除します。33秒
。
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%はオートフィルターによって使用されます
。
これまでに私が見つけた制限がいくつかありますが、最初の制限は対処できます。
最初のシートに非表示の行がある場合は、それらを表示
- それらを非表示にするには別の機能が必要です
- 実装によっては、期間が大幅に長くなる可能性があります
VBA関連:
- シートのコード名が変更されます。Sheet1 を参照する他の VBA は壊れます (存在する場合)
- 最初のシートに関連付けられたすべての VBA コードを削除します (存在する場合)
。
次のような大きなファイルを使用する場合の注意事項がいくつかあります。
- バイナリ形式 (.xlsb) によりファイル サイズが大幅に削減されます (137 MB から 43 MB)
管理されていない条件付き書式ルールは、指数関数的なパフォーマンスの問題を引き起こす可能性があります。
- コメントとデータ検証も同様です
ネットワークからファイルやデータを読み取るのは、ローカルファイルで作業するよりもはるかに遅いです。