根据条件删除整行无法处理 400,000 行

Question

我有这个宏来删除那些不是“chr9”的整行。我总共有 401,094 行。它似乎编译得很好，但我的 Excel 冻结了，我必须强制退出。

我认为这可能是一个低效的算法或者代码中的一些错误？

Sub deleteNonChr9()
    Dim lastrow As Long
    Dim firstrow As Long
    Dim i As Long

    lastrow = 401094
    firstrow = 0

    ' Increment bottom of sheet to upwards
    For i = lastrow To firstrow Step -1
        If (Range("C1").Offset(i, 0) <> "chr9") Then
            Range("C1").Offset(i, 0).EntireRow.Delete
        End If
    Next i

End Sub

Answer 1

有条件地删除行的最快方法是将它们全部放在数据块的底部。将它们排序到该位置并删除比单独循环甚至编译要删除的行的不连续 Union 更快。

当任何组或单元格是连续的（即全部在一起）时，Excel 不必费力地摆脱它们。如果它们位于Worksheet.UsedRange property 的底部，Excel 就不必计算用什么来填充空白空间。

您的原始代码不允许在第 1 行使用列标题文本标签，但我会说明这一点。如果您没有，请修改以适合。

这些将关闭计算能力的三个主要寄生虫。在 cmets 和答案中已经解决了两个问题，第三个 Application.EnableEvents property 也可以对 Sub 过程效率做出有效贡献，无论您是否有事件驱动的例程。有关详细信息，请参阅底部的辅助 Sub 过程。

样本数据²：A:Z 中的 500K 行随机数据。 ~33% Chr9 在 C:C 列中。要删除大约 333K 随机不连续的行。

Union 并删除

Option Explicit

Sub deleteByUnion()
    Dim rw As Long, dels As Range

    On Error GoTo bm_Safe_Exit
    appTGGL bTGGL:=False          'disable parasitic environment

    With Worksheets("Sheet1")
        Set dels = .Cells(.Rows.Count, "C").End(xlUp).Offset(1)
        For rw = .Cells(.Rows.Count, "C").End(xlUp).Row To 2 Step -1
            If LCase$(.Cells(rw, "C").Value2) <> "chr9" Then
                Set dels = Union(dels, .Cells(rw, "C"))
            End If
        Next rw
        If Not dels Is Nothing Then
            dels.EntireRow.Delete
        End If
    End With

bm_Safe_Exit:
    appTGGL

End Sub

^{经过的时间：}

从工作表批量加载到变量数组、更改、加载回、排序和删除

Sub deleteByArrayAndSort()
    Dim v As Long, vals As Variant

    On Error GoTo bm_Safe_Exit
    appTGGL bTGGL:=False          'disable parasitic environment

    With Worksheets("Sheet1")
        With .Cells(1, 1).CurrentRegion
            .EntireRow.Hidden = False
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
               'bulk load column C values
                vals = .Columns(3).Value2

               'change non-Chr9 values into vbNullStrings
                For v = LBound(vals, 1) To UBound(vals, 1)
                    If LCase$(vals(v, 1)) <> "chr9" Then _
                      vals(v, 1) = vbNullString
                Next v

            End With

           'dump revised array back into column C
            .Cells(2, "C").Resize(UBound(vals, 1), UBound(vals, 2)) = vals

            'sort all of blank C's to the bottom
            .Cells.Sort Key1:=.Columns(3), Order1:=xlAscending, _
                               Orientation:=xlTopToBottom, Header:=xlYes

            'delete non-Chr9 contiguous rows at bottom of currentregion
            .Range(.Cells(.Rows.Count, "C").End(xlUp), .Cells(.Rows.Count, "C")).EntireRow.Delete

        End With
        .UsedRange   'reset the last_cell property
    End With

bm_Safe_Exit:
    appTGGL

End Sub

^{已用时间：11.61 秒¹}
      _{（剩余 166,262 行数据²）}

原始代码

^{经过的时间：}

总结

在变体数组中工作以及删除连续范围具有明显的优势。我的样本数据有大约 66% 的行要删除，所以它是一个苛刻的任务大师。如果要删除 5 或 20 行，使用数组解析数据进行排序可能不是最佳解决方案。您必须根据自己的数据做出自己的决定。

appTGGL 辅助子程序

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .ScreenUpdating = bTGGL
        .EnableEvents = bTGGL
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
    End With
    Debug.Print Timer
End Sub

---

¹ _{环境：带有移动 i5 和 8gb DRAM 运行 WIN7 和 Office 2013（版本 15.0.4805.1001 MSO 15.0.4815.1000 32 位）的旧商务级笔记本电脑 - 典型的低端性能这个级别的程序。}

² _{样本数据暂时可在Deleting entire row cannot handle 400,000 rows.xlsb获取。}

Answer 2

切换屏幕更新和计算会有所帮助。但正如 Jeeped 所说，应用自定义排序顺序是可行的方法。

Sub deleteNonChr9()
    Dim lastrow As Long
    Dim firstrow As Long
    Dim i As Long

    lastrow = 401094
    firstrow = 1

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Increment bottom of sheet to upwards
    For i = lastrow To firstrow Step -1

        If (Cells(i, "C") <> "chr9") Then
            Rows(i).EntireRow.Delete
        End If

    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Answer 3

重大进展

以下处理删除大量行的代码受到Ron de Bruin - Excel Automation的启发。

Sub QuickDeleteRows()
Dim Sheet_Data As Worksheet, NewSheet_Data As Worksheet
Dim Sheet_Name As String, ZeroTime As Double, Data As Range

On Error GoTo Error_Handler
SpeedUp True

Set Sheet_Data = Sheets("Test")
Sheet_Name = Sheet_Data.Name
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

Set Data = Sheet_Data.Range("A1", Cells(LastRow, LastColumn))

Set NewSheet_Data = Sheets.Add(After:=Sheet_Data)

Data.AutoFilter Field:=3, Criteria1:="=Chr9"
Data.Copy

With NewSheet_Data.Cells
    .PasteSpecial xlPasteColumnWidths
    .PasteSpecial xlPasteAll
    .Cells(1, 1).Select
    .Cells(1, 1).Copy
End With

Sheet_Data.Delete
NewSheet_Data.Name = Sheet_Name

Safe_Exit:
    SpeedUp False
    Exit Sub
Error_Handler:
    Resume Safe_Exit
End Sub

Sub SpeedUp(SpeedUpOn As Boolean)
With Application
    If SpeedUpOn Then
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayStatusBar = False
        .DisplayAlerts = False
    Else
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayStatusBar = True
        .DisplayAlerts = True
    End If
End With
End Sub

虽然我的旧版本代码处理 sample data provided by Jeeped 需要相当长的时间（平均大约 130 秒），但上面的代码处理 400,000 行样本数据的时间不到 4.6 秒我的机器。这是一个非常显着的性能提升！

我的电脑的系统信息（学生的最低计算机配置）

• 操作系统： Windows 7 Professional 32 位（6.1，Build 7601） 服务包 1
• 系统制造商： Hewlett-Packard
• 系统型号： HP Pro 3330 MT
• 处理器： Intel(R) Core(TM) i3-2120 CPU @ 3.30GHz (4 CPU），~3.3GHz
• 内存： 2048MB RAM

---

原答案

我知道这个答案并不是 OP 真正想要的，但也许这个答案可能对其他用户有用，并且对未来的用户有帮助，如果不是 OP。请将此答案视为替代方法。

在 Excel 中进行

复制/粘贴、剪切/插入和删除整行操作可能需要很长时间，即使在VBA Excel。对于复制/粘贴和剪切/插入操作，速度缓慢的原因是数据本身的格式。内存过度分配是这些操作的另一个原因。那么我们如何解决这样的情况呢？您可以寻找几件事情来加速您的代码。

1. 使用数组而不是单元格区域。它通常被认为比处理单元格范围更快，因为它忽略了单元格中数据的格式。
2. 使用 .Value2 而不是默认属性 (.Value)，因为 .Value2 只会将所有格式数字（货币、会计、日期、科学等）视为双精度数。

假设我们有 10,000 行虚拟数据，如以下数据集：

我没有删除整行“非 chr9”数据，而是简单地忽略这些数据，而仅通过将所有“chr9”数据复制到数组中来考虑“chr9”数据。如何编写代码来实现这样的任务？首先，我们必须制作数据副本以避免数据丢失，因为我们无法在运行后撤消所有更改以恢复原始数据VBA Excel。

看来您已经完成了所有需要的准备工作。现在，我们可以开始编码，首先将我们需要的每个变量声明为适当的数据类型。

Dim i As Long, j As Long, k As Long
Dim LastRow As Long, LastColumn As Long, LengthDataChr9 As Long

如果您不声明变量，您的代码将使用默认为 Variant 类型的变量运行。虽然 Variant 非常有用，但它会使您的代码变慢。因此，请确保使用合理的类型声明每个变量。这是一种很好的编程习惯，而且速度要快得多。

接下来，我们确定将用于构造数组大小的所有变量。我们需要

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column

LastRow 和LastColumn 是最后一个单元格的行号和列号，其中数据在一行或一列中。请记住，如果您没有正确设置它们或使用格式正确的数据表，LastRow 和 LastColumn 可能无法为您提供所需的行号和列号。我所说的“格式良好的数据表”是指一个工作表，其数据从单元格 A1 开始，A 列中的行数和第 1 行中的列数必须等于所有数据的范围。也就是说，所有数据的范围大小必须等于LastRowxLastColumn。

我们还需要数组的长度来存储所有“chr9”数据。这可以通过使用以下语句计算所有“chr9”数据来完成：

LengthDataChr9 = Application.CountIf(Columns("C"), "chr9")

我们现在知道了数组的大小，我们可以重新调整它的大小。添加以下代码行：

ReDim Data(1 To LastRow, 1 To LastColumn)
ReDim DataChr9(1 To LengthDataChr9, 1 To LastColumn)

我们使用ReDim 而不是Dim，因为我们使用动态数组。 VBA Excel 已自动声明默认为 Variant 类型的数组，但它们还没有大小。接下来，我们通过 using 语句将数据复制到数组Data中

Data = Range("A1", Cells(LastRow, LastColumn)).Value2

我们使用.Value2 来提高代码的性能（请参阅上面的加速技巧第 2 点）。由于数据已经复制到数组Data，我们可以清除工作表数据，以便我们可以使用它来粘贴DataChr9。

Rows("1:" & Rows.Count).ClearContents

要清除工作表上的所有内容（所有内容、格式等），我们可以使用Sheets("Sheet1").Cells.Clear 或Sheet1.Cells.Clear。接下来，我们希望代码使用 For ... Next 语句循环遍历第 3 列中的元素数组 Data，因为我们要查找的所需数据位于此处。如果找到数组Data 的元素包含字符串“chr9”，则代码将“chr9”所在行中的所有元素复制到DataChr9。我们再次使用 For ... Next 语句。以下是执行这些程序的行。

For i = 1 To UBound(Data)
    If Data(i, 3) = "chr9" Then
        j = j + 1
            For k = 1 To LastColumn
                DataChr9(j, k) = Data(i, k)
            Next k
    End If
Next i

其中j = j + 1 是一个计数器，用于循环遍历DataChr9 的行。最后一步，我们通过在代码中添加这一行将DataChr9 的所有元素粘贴回工作表：

Range("A1", Cells(LengthDataChr9, LastColumn)) = DataChr9

然后你就完成了！ 耶，终于！

---

好的，让我们编译上面所有的行代码。我们得到

Sub DeleteNonChr9()
Dim i As Long, j As Long, k As Long
Dim LastRow As Long, LastColumn As Long, LengthDataChr9 As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
LengthDataChr9 = Application.CountIf(Columns("C"), "chr9")

ReDim Data(1 To LastRow, 1 To LastColumn)
ReDim DataChr9(1 To LengthDataChr9, 1 To LastColumn)

Data = Range("A1", Cells(LastRow, LastColumn)).Value2
Rows("1:" & Rows.Count).ClearContents

For i = 1 To UBound(Data)
    If Data(i, 3) = "chr9" Then
        j = j + 1
            For k = 1 To LastColumn
                DataChr9(j, k) = Data(i, k)
            Next k
    End If
Next i

Range("A1", Cells(LengthDataChr9, LastColumn)) = DataChr9
End Sub

上述代码的性能令人满意。完成从我机器上的 10,000 行虚拟数据中提取所有“chr9”数据的过程平均不到 0.5 秒。