删除无法用SpecialCells抓取的行的最快方法
基于本网站上的另一个问题 ，我开始想知道删除所有具有一定条件的行的最快方法。
上面提到的问题带有各种解决scheme：
（1）循环浏览表单中的所有行（向后）并删除符合条件的所有行。
（2）首先将适用的范围移动到数组中，然后评估数组中的条件，并基于此 – 在基础工作表上逐个删除所有行。
可能的改进可能是删除块中的所有行，以减less访问工作表的开销。 但是，如果你走这条路线，那么在你实际删除之前，你有各种select来“存储”范围：
（1）使用Intersect来合并应该删除的范围。
（2）简单地写一个所有要删除的行的String 。
那么，这是最快的方法呢？
一个有效的解决scheme是标记所有行以保留并移动所有行，最后通过sorting标签来删除。 这样，复杂度不会随着要删除的行数而增加。
这个例子在不到一秒的时间内，对于50000行，列I所有行都等于2 ：
Sub DeleteMatchingRows() Dim rgTable As Range, rgTags As Range, data(), tags(), count&, r& ' load the data in an array Set rgTable = ActiveSheet.UsedRange data = rgTable.Value ' tag all the rows to keep with the row number. Leave empty otherwise. ReDim tags(1 To UBound(data), 1 To 1) tags(1, 1) = 1 ' keep the header For r = 2 To UBound(data) If data(r, 9) <> 2 Then tags(r, 1) = r ' if column I <> 2 keep the row Next ' insert the tags in the last column on the right Set rgTags = rgTable.Columns(rgTable.Columns.count + 1) rgTags.Value = tags ' sort the rows on the tags which will move the rows to delete at the end Union(rgTable, rgTags).Sort key1:=rgTags, Orientation:=xlTopToBottom, Header:=xlYes count = rgTags.End(xlDown).Row ' delete the tags on the right and the rows that weren't tagged rgTags.EntireColumn.Delete rgTable.Resize(UBound(data) - count + 1).Offset(count).EntireRow.Delete End Sub
请注意，它不会改变行的顺序。
以下是我可以用“平均时间”来完成任务的所有可能选项：
Option Base 1 Option Explicit Sub FixWithArraysAndDeleteRange() Dim lngItem As Long Dim varArray() As Variant Dim wksItem As Worksheet Dim rngRangeToDelete As Range Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) varArray() = wksItem.Range("I25:I50000").Value2 For lngItem = LBound(varArray) To UBound(varArray) If IsNumeric(varArray(lngItem, 1)) Then If Int(varArray(lngItem, 1)) = 2 Then If rngRangeToDelete Is Nothing Then Set rngRangeToDelete = wksItem.Rows(lngItem + 24) Else Set rngRangeToDelete = Intersect(rngRangeToDelete, wksItem.Rows(lngItem + 24)) End If End If End If Next lngItem rngRangeToDelete.EntireRow.Delete Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time around 0 seconds End Sub
Sub FixWithLoop() Dim lngRow As Long Dim lngLastRow As Long Dim wksItem As Worksheet Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) lngLastRow = wksItem.Cells(wksItem.Rows.Count, "I").End(xlUp).Row For lngRow = lngLastRow To 25 Step -1 If Int(wksItem.Cells(lngRow, "I").Value) = 2 Then wksItem.Rows(lngRow).Delete Next lngRow Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time ~3 seconds End Sub
Sub FixWithLoopInChunks() Dim lngRow As Long Dim lngLastRow As Long Dim wksItem As Worksheet Dim strRowsToDelete As String Dim intDeleteCount As Integer Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) lngLastRow = wksItem.Cells(wksItem.Rows.Count, "I").End(xlUp).Row For lngRow = lngLastRow To 25 Step -1 If Int(wksItem.Cells(lngRow, "I").Value) = 2 Then intDeleteCount = intDeleteCount + 1 strRowsToDelete = strRowsToDelete & ",I" & lngRow End If If intDeleteCount >= 30 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete intDeleteCount = 0 strRowsToDelete = "" End If Next lngRow If intDeleteCount > 0 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time ~3 seconds End Sub
Sub FixWithArraysAndDeleteChunks() Dim lngItem As Long Dim varArray() As Variant Dim wksItem As Worksheet Dim strRowsToDelete As String Dim intDeleteCount As Integer Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) varArray() = wksItem.Range("I25:I50000").Value2 For lngItem = UBound(varArray) To LBound(varArray) Step -1 If IsNumeric(varArray(lngItem, 1)) Then If Int(varArray(lngItem, 1)) = 2 Then intDeleteCount = intDeleteCount + 1 strRowsToDelete = strRowsToDelete & ",I" & lngItem + 24 End If If intDeleteCount >= 30 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete intDeleteCount = 0 strRowsToDelete = "" End If End If Next lngItem If intDeleteCount > 0 Then strRowsToDelete = Mid(strRowsToDelete, 2) wksItem.Range(strRowsToDelete).EntireRow.Delete End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time ~2 seconds End Sub
基于上述testing，“最快”路线是使用数组，使用Intersect保存要删除的行的范围，然后一起删除所有行。
请注意，如果您使用的是Application.Union而不是Intersect则该方法的时间会显着下降，并且该子将运行近30秒。
但是，时间差异非常小，可以忽略不计（50,000行）。
请让我知道，如果我的速度testing设置有任何缺陷，可能会偏差的结果，或者如果我错过了另一种方法，你想看到。
更新：
这是@SiddharthRout提供的另一种方法。 我不想抄袭。 然而，我想比较时间的结果。 因此，这里是重写与我的系统上logging的平均时间相比。
Sub DeleteFilteredRows_SiddharthRout() Dim wksItem As Worksheet Dim rngRowsToDelete As Range Dim dttStart As Date Worksheets(1).Range("I25:I50000").Formula = "=RandBetween(1, 5)" Worksheets(1).Range("I25:I50000").Value2 = Worksheets(1).Range("I25:I50000").Value2 dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wksItem = Worksheets(1) wksItem.AutoFilterMode = False wksItem.Range("I25:I50000").AutoFilter Field:=1, Criteria1:=2 Set rngRowsToDelete = wksItem.Range("I25:I50000").SpecialCells(xlCellTypeVisible) wksItem.AutoFilterMode = False wksItem.Rows.Hidden = False rngRowsToDelete.EntireRow.Delete Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time around 5 seconds End Sub
这个方法似乎比其他所有方法稍慢。
编辑
经过一些更多的testing，似乎Sort ＆ Delete比RemoveDuplicates快一点
所以我提出了以下解决scheme（在答案的最后保留第一个参考）
Sub FixWithSort() Dim testRng As Range Dim dttStart As Date Set testRng = Worksheets("Test").Range("I25:I50000") With testRng .Formula = "=RandBetween(1, 5)" .Value2 = .Value2 End With dttStart = Now() With testRng With .Offset(, 1) .FormulaR1C1 = "=IF(RC[-1]=2,"""",row())" .Value2 = .Value2 End With .Resize(, 2).Sort key1:=.Columns(2), Orientation:=xlTopToBottom, Header:=xlYes Range(.Cells(1, 2).End(xlDown).Offset(1, -1), .Cells(1, 1).End(xlDown)).EntireRow.Delete .Columns(2).ClearContents End With Debug.Print Format(Now() - dttStart, "HH:MM:SS") dttStartGlobal = dttStartGlobal + Now() - dttStart End Sub
使用RemoveDuplicates以前的（稍慢的）解决scheme
Option Explicit Sub FixWithRemoveDuplicates() Dim testRng As Range Dim dttStart As Date Set testRng = Worksheets("Test").Range("I25:I50000") With testRng .Formula = "=RandBetween(1, 5)" .Value2 = .Value2 End With dttStart = Now() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False With testRng With .Offset(, 1) .FormulaR1C1 = "=IF(RC[-1]=2,""a"",row())" .Value2 = .Value2 End With .EntireRow.RemoveDuplicates Columns:=Array(.Columns(2).Column), Header:=xlNo .Offset(, 1).Find(what:="a", LookIn:=xlValues, LookAt:=xlWhole).EntireRow.Delete .Columns(2).ClearContents End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print Format(Now() - dttStart, "HH:MM:SS") 'Average time around 0 seconds End Sub
