VBA 删除不包含特定值的行的更快或最佳替代方案？

Question

为了节省大家的时间，快速提问：

我的下面的代码工作正常，但对于我的 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

有什么修改可以让它更快吗？你会使用不同的逻辑吗？

Answer 1

请尝试下一个更新的代码。它应该非常快：

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范围版本测试上述（大大改进）的方法，我想象了下一个测试方法：

1. 在模块顶部放置一个常量声明来保留测试代码（在声明区域中）：

 Private Const arrRepeat As Long = 5000

2. 复制构建类似环境的下一个代码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

3. 现在运行三个版本中的每一个以获得相同的arrRepeat值。您首先需要激活一张空纸...

我获得了（在Immediate Window）下一个运行时间：

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 range 版本，但大约 15 分钟后我不得不关闭 Excel...