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

切换ScreenUpdating和计算会有所帮助。但正如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 2

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

当任何一个或多个单元格是连续的（即所有组合在一起）时，Excel不必努力去除它们。如果它们位于Worksheet.UsedRange property的底部，则Excel不必计算用空格填充空格的内容。

您的原始代码不允许第1行中的列标题文本标签，但我会考虑到这一点。如果您没有，请修改以适应。

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

样本数据²：A：Z中的500K行随机数据。 C列中的〜33％Chr9：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

^{经过的时间：＆lt;已经过了20分钟......完成后我会更新...＆gt;}

从工作表到变体数组的批量加载，更改，加载，排序和删除

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行数据²）}

原始代码

^{经过的时间：＆lt;仍在等待......＆gt;}

<强>摘要

在变量数组中工作以及删除连续范围有明显的优势。我的示例数据有大约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和8gbs的DRAM运行WIN7和Office 2013（版本15.0.4805.1001 MSO 15.0.4815.1000 32位） - 典型的低端执行这个级别的程序。}

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

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

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

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

操作系统：Windows 7 Professional 32位（6.1，Build 7601） Service Pack 1
系统制造商： Hewlett-Packard
系统型号：HP Pro 3330 MT
处理器：英特尔（R）酷睿（TM）i3-2120 CPU @ 3.30GHz（4 CPU），~3.3GHz
内存： 2048MB RAM

原始答案

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

复制/粘贴，剪切/插入以及删除 Excel中的整行操作即使在执行此操作时也可能会花费很长时间VBA Excel。对于复制/粘贴和剪切/插入操作，缓慢的原因是数据本身的格式化。内存过度分配是这些操作的另一个原因。那么我们如何解决这样的情况呢？您可以通过以下几种方法加快代码速度。

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

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

而不是删除＆＃34;非chr9＆＃34;的整行。数据，我只是忽略这些数据，只考虑＆＃34; chr9＆＃34;数据通过复制所有＆＃34; chr9＆＃34;数据到数组中。如何编写代码来实现这样的任务？首先，我们必须复制我们的数据以避免数据丢失，因为我们无法撤消所有更改以在运行后恢复原始数据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可能无法为您提供所需的行号和列号，如果您没有正确设置它们或使用格式正确的数据表。我的意思是格式良好的数据表＆＃34;，是一个工作表，数据从单元格A1开始，列A中的行数和第1行中的行数必须等于所有行的范围数据。换句话说，所有数据范围的大小必须等于LastRow x LastColumn。

我们还需要数组的长度来存储所有＆＃34; chr9＆＃34;数据。这可以通过计算所有＆＃34; chr9＆＃34;数据使用以下语句：

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类型，但它们还没有大小。接下来，我们使用语句

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的元素包含字符串＆＃34; chr9＆＃34;找到，然后代码复制行中的所有元素＆＃34; chr9＆＃34;位于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

上面代码的性能令人满意。平均花费不到0.5秒就可以完成提取所有＆＃34; chr9＆＃34;我机器上10,000行虚拟数据的数据。

删除标准上的整行不能处理400,000行

3 个答案:

重大进展

原始答案