VBA 删除不包含特定值的行的更快或最佳替代方案？
Faster Or Best Alternative for VBA to delete rows not containing specific values?
节省大家时间的快速提问：
下面的代码运行良好，但对于我的 30,000 多行来说太慢了。
它基本上删除了 AD 列中不包含状态 TX、AR、LA 和 OK 的所有行。
Sub DeleteStateExceptions()
Dim iLastRow As Long
Dim i As Long
iLastRow = Cells(Rows.Count, "AD").End(xlUp).Row
For i = iLastRow To 2 Step -1
Select Case Cells(i, "AD").Value
Case "TX"
Case "OK"
Case "AR"
Case "LA"
Case Else
Rows(i).Delete
End Select
Next i
'deletes row when cell in column AD is not TX, OK, AR or LA
End Sub
有什么修改可以让它更快吗？你会使用不同的逻辑吗？
请尝试下一个更新的代码。应该很快：
Sub DeleteStateExceptions()
Dim iLastRow As Long, arrMark, lastEmptyCol As Long, i As Long, boolDel As Boolean
iLastRow = cells(rows.count, "AD").End(xlUp).Row
lastEmptyCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.count + 1
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = 2 To iLastRow
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
boolDel = True 'to delete only if at least a row has been marked
arrMark(i - 1, 1) = "Del"
End Select
Next i
If boolDel Then
With cells(2, lastEmptyCol).Resize(UBound(arrMark), 1)
.value = arrMark
.SpecialCells(xlCellTypeConstants).EntireRow.Delete
End With
End If
End Sub
另一种方法是创建一个 Union 范围，但如果范围很大，创建这个范围会严重降低速度。您可以设置最大单元格限制（向后迭代），比方说，100，删除已经在 Union 范围内的行并将其设置为 Nothing.
但是我认为上面的解决方案应该是最快的...
已编辑:
我答应回来提供一个解决方案，超越不连续范围内特定数量数组的限制。我只知道 8192 用于 2007 年之前的版本。看起来，这样的限制也存在于较新的版本中，即使更大。为了针对 Union 范围版本测试上述（改进很多）方式，我设想了下一个测试方式：
- 在保留测试代码的模块顶部放置一个常量声明（在声明区域）：
Private Const arrRepeat As Long = 5000
- 复制下一个
Sub构建类似环境的代码，以类似的方式测试版本，加上排序：
3. Copy the improved above version, being extremely fast:
Sub DeleteStateExceptions()
Dim iLastRow As Long, arrMark, lastEmptyCol As Long, i As Long, boolDel As Boolean
Dim tm, arrSort
buildTestingRange arrRepeat
tm = Timer
iLastRow = cells(rows.count, "AD").End(xlUp).Row
arrSort = Evaluate("ROW(1:" & iLastRow - 1 & ")") 'create an array of necessary existing rows number
lastEmptyCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.count + 1
cells(1, lastEmptyCol + 1).value = "InitSort" 'place a header to the initial sort column
cells(2, lastEmptyCol + 1).Resize(UBound(arrSort), 1).value = arrSort 'drop the array content in the column
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = 2 To iLastRow
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
boolDel = True
arrMark(i - 1, 1) = "Del"
End Select
Next i
If boolDel Then
With cells(2, lastEmptyCol).Resize(UBound(arrMark), 1)
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual 'some optimization...
.value = arrMark 'drop the arrMark content
'sort the area where the above array content has been dropped:
SortByColumn Range("A1", cells(iLastRow, lastEmptyCol + 1)), Range(cells(1, lastEmptyCol), cells(iLastRow, lastEmptyCol))
.SpecialCells(xlCellTypeConstants).EntireRow.Delete 'delete the rows containing "Del"
'sort according to the original sheet initial sorting:
SortByColumn Range("A1", cells(iLastRow, lastEmptyCol + 1)), Range(cells(1, lastEmptyCol + 1), cells(iLastRow, lastEmptyCol + 1)), True
Range(cells(1, lastEmptyCol), cells(iLastRow, lastEmptyCol + 1)).Clear 'clear the helping column (the original sorting of the sheet)
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End With
End If
Debug.Print "Markers: Delete rows in " & Round(Timer - tm, 2) & " sec (" & arrRepeat & ")"
End Sub
Sub SortByColumn(rng As Range, rngS As Range, Optional boolAscending As Boolean = False)
rngS.cells(1).value = "LastColumn"
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 key:=rngS, SortOn:=xlSortOnValues, Order:=IIf(boolAscending, xlAscending, xlDescending), DataOption:= _
xlSortNormal
With ActiveSheet.Sort
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
然后复制Union范围版本：
Sub DeleteStateExceptionsUnion()
Dim iLastRow As Long, rngDel As Range, i As Long
Dim tm
buildTestingRange arrRepeat
tm = Timer
iLastRow = cells(rows.count, "AD").End(xlUp).Row
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = 2 To iLastRow
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
If rngDel Is Nothing Then
Set rngDel = cells(i, "AD")
Else
Set rngDel = Union(rngDel, cells(i, "AD"))
End If
End Select
Next i
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Debug.Print "Union: Delete rows in " & Round(Timer - tm, 2) & " sec (" & arrRepeat & ")"
End Sub
最后，批量使用Union的版本，以避免在需要非常大的范围时代码变慢：
Sub DeleteStateExceptionsUnionBatch()
Dim iLastRow As Long, rngDel As Range, i As Long
Dim tm, batch As Long, count As Long
buildTestingRange arrRepeat
tm = Timer
batch = 700
iLastRow = cells(rows.count, "AD").End(xlUp).Row
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = iLastRow To 2 Step -1 'iterate backwards
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
count = count + 1
If rngDel Is Nothing Then
Set rngDel = cells(i, "AD")
Else
Set rngDel = Union(rngDel, cells(i, "AD"))
End If
If count >= batch Then
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
rngDel.EntireRow.Delete: Set rngDel = Nothing: count = 0
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End If
End Select
Next i
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Debug.Print "Union batch: Delete rows in " & Round(Timer - tm, 2) & " sec (" & arrRepeat & ") batch: " & batch
End Sub
- 现在 运行 三个版本中的每一个都具有相同的
arrRepeat 值。您首先需要激活一个空的 sheet...
我获得了（在 Immediate Window）接下来的 运行ning 次：
Built testing range (5000 rows)
Markers: Delete rows in 0.33 sec (5000)
Built testing range (5000 rows)
Union: Delete rows in 24 sec (5000)
Built testing range (5000 rows)
Union batch: Delete rows in 18.79 sec (5000) batch: 600
Built testing range (5000 rows)
Union batch: Delete rows in 18.97 sec (5000) batch: 500
-------------------------------------------------------
Built testing range (10000 rows)
Markers: Delete rows in 0.43 sec (10000)
Built testing range (10000 rows)
Union: Delete rows in 51.23 sec (10000)
Built testing range (10000 rows)
Union batch: Delete rows in 14.57 sec (10000) batch: 500
--------------------------------------------------------
Built testing range (50000 rows)
Markers: Delete rows in 1.34 sec (50000)
Built testing range (50000 rows)
Union batch: Delete rows in 129.36 sec (50000) batch: 500
Built testing range (50000 rows)
Union batch: Delete rows in 125.47 sec (50000) batch: 600
Built testing range (50000 rows)
我尝试了 Union 范围版本，但我不得不在大约 15 分钟后关闭 Excel...
删除 Not-Criteria 行
- 当criteria列未排序时，删除数百甚至数万行可能需要'forever'。
- 下面将插入和填充两列，一个整数序列列和一个匹配列。
- 数据按匹配列排序后，现在连续的错误值范围将用于快速删除不需要的行。
- 整数序列列将用于最终排序数据以恢复初始顺序。
Sub DeleteNotCriteriaRowsTEST()
Const CriteriaList As String = "TX,OK,AR,LA"
Const FirstCellAddress As String = "AD2"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim FirstCell As Range: Set FirstCell = ws.Range(FirstCellAddress)
DeleteNotCriteriaRows FirstCell, CriteriaList
End Sub
Sub DeleteNotCriteriaRows( _
ByVal FirstCell As Range, _
ByVal CriteriaList As String, _
Optional ByVal CriteriaDelimiter As String = ",")
Const ProcName As String = "DeleteNotCriteriaRows"
Dim NothingToDelete As Boolean
On Error GoTo ClearError
Dim Criteria() As String: Criteria = Split(CriteriaList, CriteriaDelimiter)
Dim ws As Worksheet
Dim rgColumn As Range
Dim rCount As Long
With FirstCell.Cells(1)
Set ws = .Worksheet
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count _
- .Row + 1).Find("*", , xlFormulas, , , xlPrevious)
rCount = lCell.Row - .Row + 1
Set rgColumn = .Resize(rCount)
End With
Dim rgTotal As Range
Set rgTotal = Intersect(ws.UsedRange, rgColumn.EntireRow)
Application.ScreenUpdating = False
Dim rgInsert As Range
Set rgInsert = rgColumn.Cells(1).Offset(, 1).Resize(, 2).EntireColumn
rgInsert.Insert xlShiftToRight, xlFormatFromLeftOrAbove
Dim rgIntegerSequence As Range: Set rgIntegerSequence = rgColumn.Offset(, 1)
With rgIntegerSequence
.NumberFormat = "0"
.Formula = "=ROW()"
.Value = .Value
End With
Dim rgMatch As Range: Set rgMatch = rgColumn.Offset(, 2)
With rgMatch
.NumberFormat = "General"
.Value = Application.Match(rgColumn, Criteria, 0)
End With
rgTotal.Sort rgMatch, xlAscending, , , , , , xlNo
Dim rgDelete As Range
On Error Resume Next
Set rgDelete = Intersect(ws.UsedRange, _
rgMatch.SpecialCells(xlCellTypeConstants, xlErrors).EntireRow)
On Error GoTo ClearError
If rgDelete Is Nothing Then
NothingToDelete = True
Else
rgDelete.Delete xlShiftUp
End If
rgTotal.Sort rgIntegerSequence, xlAscending, , , , , , xlNo
rgInsert.Offset(, -2).Delete xlShiftToLeft
SafeExit:
Application.ScreenUpdating = True
If NothingToDelete Then
MsgBox "Nothing deleted.", vbExclamation, ProcName
Else
MsgBox "Rows deleted.", vbInformation, ProcName
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
NothingToDelete = True
Resume SafeExit
End Sub
节省大家时间的快速提问：
下面的代码运行良好，但对于我的 30,000 多行来说太慢了。
它基本上删除了 AD 列中不包含状态 TX、AR、LA 和 OK 的所有行。
Sub DeleteStateExceptions()
Dim iLastRow As Long
Dim i As Long
iLastRow = Cells(Rows.Count, "AD").End(xlUp).Row
For i = iLastRow To 2 Step -1
Select Case Cells(i, "AD").Value
Case "TX"
Case "OK"
Case "AR"
Case "LA"
Case Else
Rows(i).Delete
End Select
Next i
'deletes row when cell in column AD is not TX, OK, AR or LA
End Sub
有什么修改可以让它更快吗？你会使用不同的逻辑吗？
请尝试下一个更新的代码。应该很快：
Sub DeleteStateExceptions()
Dim iLastRow As Long, arrMark, lastEmptyCol As Long, i As Long, boolDel As Boolean
iLastRow = cells(rows.count, "AD").End(xlUp).Row
lastEmptyCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.count + 1
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = 2 To iLastRow
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
boolDel = True 'to delete only if at least a row has been marked
arrMark(i - 1, 1) = "Del"
End Select
Next i
If boolDel Then
With cells(2, lastEmptyCol).Resize(UBound(arrMark), 1)
.value = arrMark
.SpecialCells(xlCellTypeConstants).EntireRow.Delete
End With
End If
End Sub
另一种方法是创建一个 Union 范围，但如果范围很大，创建这个范围会严重降低速度。您可以设置最大单元格限制（向后迭代），比方说，100，删除已经在 Union 范围内的行并将其设置为 Nothing.
但是我认为上面的解决方案应该是最快的...
已编辑:
我答应回来提供一个解决方案，超越不连续范围内特定数量数组的限制。我只知道 8192 用于 2007 年之前的版本。看起来，这样的限制也存在于较新的版本中，即使更大。为了针对 Union 范围版本测试上述（改进很多）方式，我设想了下一个测试方式：
- 在保留测试代码的模块顶部放置一个常量声明（在声明区域）：
Private Const arrRepeat As Long = 5000
- 复制下一个
Sub构建类似环境的代码，以类似的方式测试版本，加上排序：
3. Copy the improved above version, being extremely fast:
Sub DeleteStateExceptions()
Dim iLastRow As Long, arrMark, lastEmptyCol As Long, i As Long, boolDel As Boolean
Dim tm, arrSort
buildTestingRange arrRepeat
tm = Timer
iLastRow = cells(rows.count, "AD").End(xlUp).Row
arrSort = Evaluate("ROW(1:" & iLastRow - 1 & ")") 'create an array of necessary existing rows number
lastEmptyCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.count + 1
cells(1, lastEmptyCol + 1).value = "InitSort" 'place a header to the initial sort column
cells(2, lastEmptyCol + 1).Resize(UBound(arrSort), 1).value = arrSort 'drop the array content in the column
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = 2 To iLastRow
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
boolDel = True
arrMark(i - 1, 1) = "Del"
End Select
Next i
If boolDel Then
With cells(2, lastEmptyCol).Resize(UBound(arrMark), 1)
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual 'some optimization...
.value = arrMark 'drop the arrMark content
'sort the area where the above array content has been dropped:
SortByColumn Range("A1", cells(iLastRow, lastEmptyCol + 1)), Range(cells(1, lastEmptyCol), cells(iLastRow, lastEmptyCol))
.SpecialCells(xlCellTypeConstants).EntireRow.Delete 'delete the rows containing "Del"
'sort according to the original sheet initial sorting:
SortByColumn Range("A1", cells(iLastRow, lastEmptyCol + 1)), Range(cells(1, lastEmptyCol + 1), cells(iLastRow, lastEmptyCol + 1)), True
Range(cells(1, lastEmptyCol), cells(iLastRow, lastEmptyCol + 1)).Clear 'clear the helping column (the original sorting of the sheet)
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End With
End If
Debug.Print "Markers: Delete rows in " & Round(Timer - tm, 2) & " sec (" & arrRepeat & ")"
End Sub
Sub SortByColumn(rng As Range, rngS As Range, Optional boolAscending As Boolean = False)
rngS.cells(1).value = "LastColumn"
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 key:=rngS, SortOn:=xlSortOnValues, Order:=IIf(boolAscending, xlAscending, xlDescending), DataOption:= _
xlSortNormal
With ActiveSheet.Sort
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
然后复制Union范围版本：
Sub DeleteStateExceptionsUnion()
Dim iLastRow As Long, rngDel As Range, i As Long
Dim tm
buildTestingRange arrRepeat
tm = Timer
iLastRow = cells(rows.count, "AD").End(xlUp).Row
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = 2 To iLastRow
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
If rngDel Is Nothing Then
Set rngDel = cells(i, "AD")
Else
Set rngDel = Union(rngDel, cells(i, "AD"))
End If
End Select
Next i
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Debug.Print "Union: Delete rows in " & Round(Timer - tm, 2) & " sec (" & arrRepeat & ")"
End Sub
最后，批量使用Union的版本，以避免在需要非常大的范围时代码变慢：
Sub DeleteStateExceptionsUnionBatch()
Dim iLastRow As Long, rngDel As Range, i As Long
Dim tm, batch As Long, count As Long
buildTestingRange arrRepeat
tm = Timer
batch = 700
iLastRow = cells(rows.count, "AD").End(xlUp).Row
ReDim arrMark(1 To iLastRow - 1, 1 To 1)
For i = iLastRow To 2 Step -1 'iterate backwards
Select Case cells(i, "AD").value
Case "TX", "OK", "AR", "LA"
Case Else
count = count + 1
If rngDel Is Nothing Then
Set rngDel = cells(i, "AD")
Else
Set rngDel = Union(rngDel, cells(i, "AD"))
End If
If count >= batch Then
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
rngDel.EntireRow.Delete: Set rngDel = Nothing: count = 0
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End If
End Select
Next i
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
Debug.Print "Union batch: Delete rows in " & Round(Timer - tm, 2) & " sec (" & arrRepeat & ") batch: " & batch
End Sub
- 现在 运行 三个版本中的每一个都具有相同的
arrRepeat值。您首先需要激活一个空的 sheet...
我获得了（在 Immediate Window）接下来的 运行ning 次：
Built testing range (5000 rows)
Markers: Delete rows in 0.33 sec (5000)
Built testing range (5000 rows)
Union: Delete rows in 24 sec (5000)
Built testing range (5000 rows)
Union batch: Delete rows in 18.79 sec (5000) batch: 600
Built testing range (5000 rows)
Union batch: Delete rows in 18.97 sec (5000) batch: 500
-------------------------------------------------------
Built testing range (10000 rows)
Markers: Delete rows in 0.43 sec (10000)
Built testing range (10000 rows)
Union: Delete rows in 51.23 sec (10000)
Built testing range (10000 rows)
Union batch: Delete rows in 14.57 sec (10000) batch: 500
--------------------------------------------------------
Built testing range (50000 rows)
Markers: Delete rows in 1.34 sec (50000)
Built testing range (50000 rows)
Union batch: Delete rows in 129.36 sec (50000) batch: 500
Built testing range (50000 rows)
Union batch: Delete rows in 125.47 sec (50000) batch: 600
Built testing range (50000 rows)
我尝试了 Union 范围版本，但我不得不在大约 15 分钟后关闭 Excel...
删除 Not-Criteria 行
- 当criteria列未排序时，删除数百甚至数万行可能需要'forever'。
- 下面将插入和填充两列，一个整数序列列和一个匹配列。
- 数据按匹配列排序后，现在连续的错误值范围将用于快速删除不需要的行。
- 整数序列列将用于最终排序数据以恢复初始顺序。
Sub DeleteNotCriteriaRowsTEST()
Const CriteriaList As String = "TX,OK,AR,LA"
Const FirstCellAddress As String = "AD2"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim FirstCell As Range: Set FirstCell = ws.Range(FirstCellAddress)
DeleteNotCriteriaRows FirstCell, CriteriaList
End Sub
Sub DeleteNotCriteriaRows( _
ByVal FirstCell As Range, _
ByVal CriteriaList As String, _
Optional ByVal CriteriaDelimiter As String = ",")
Const ProcName As String = "DeleteNotCriteriaRows"
Dim NothingToDelete As Boolean
On Error GoTo ClearError
Dim Criteria() As String: Criteria = Split(CriteriaList, CriteriaDelimiter)
Dim ws As Worksheet
Dim rgColumn As Range
Dim rCount As Long
With FirstCell.Cells(1)
Set ws = .Worksheet
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count _
- .Row + 1).Find("*", , xlFormulas, , , xlPrevious)
rCount = lCell.Row - .Row + 1
Set rgColumn = .Resize(rCount)
End With
Dim rgTotal As Range
Set rgTotal = Intersect(ws.UsedRange, rgColumn.EntireRow)
Application.ScreenUpdating = False
Dim rgInsert As Range
Set rgInsert = rgColumn.Cells(1).Offset(, 1).Resize(, 2).EntireColumn
rgInsert.Insert xlShiftToRight, xlFormatFromLeftOrAbove
Dim rgIntegerSequence As Range: Set rgIntegerSequence = rgColumn.Offset(, 1)
With rgIntegerSequence
.NumberFormat = "0"
.Formula = "=ROW()"
.Value = .Value
End With
Dim rgMatch As Range: Set rgMatch = rgColumn.Offset(, 2)
With rgMatch
.NumberFormat = "General"
.Value = Application.Match(rgColumn, Criteria, 0)
End With
rgTotal.Sort rgMatch, xlAscending, , , , , , xlNo
Dim rgDelete As Range
On Error Resume Next
Set rgDelete = Intersect(ws.UsedRange, _
rgMatch.SpecialCells(xlCellTypeConstants, xlErrors).EntireRow)
On Error GoTo ClearError
If rgDelete Is Nothing Then
NothingToDelete = True
Else
rgDelete.Delete xlShiftUp
End If
rgTotal.Sort rgIntegerSequence, xlAscending, , , , , , xlNo
rgInsert.Offset(, -2).Delete xlShiftToLeft
SafeExit:
Application.ScreenUpdating = True
If NothingToDelete Then
MsgBox "Nothing deleted.", vbExclamation, ProcName
Else
MsgBox "Rows deleted.", vbInformation, ProcName
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
NothingToDelete = True
Resume SafeExit
End Sub