优化 Excel VBA 代码答案

【问题标题】：Optimize Excel VBA Code优化 Excel VBA 代码
【发布时间】：2013-11-06 01:03:34
【问题描述】：

我在 excel 中有以下 VBA 代码。它的目标是在找到给定文本时删除一行，以及删除它正下方的行。它需要扫描大约 700k 行，并且大约需要一个小时来扫描 100k 行。有人看到优化了吗？

Sub RemovePageHeaders()
    Application.ScreenUpdating = False
    Dim objRange As Range
    Set objRange = Cells.Find("HeaderText")
    While objRange <> ""
        objRange.Offset(1, 0).Rows(1).EntireRow.Delete
        objRange.Rows(1).EntireRow.Delete
        Set objRange = Cells.Find("HeaderText")
    Wend
    MsgBox ("I'm done removing page headers!")
End Sub

提前致谢！

【问题讨论】：

“HeaderText”是否只出现在一个特定的列中？

标签： excel vba

【解决方案1】：

试试下面的子。它从最底部的行循环到顶部，检查第 3 列的“HeaderText”。如果找到，它将删除该行及其下方的行。在具有 2 GB RAM 的 C2D E8500 上，在具有 100 万行的工作表上，每 100,000 行只需要一分钟多一点的时间。

Sub RemoveHeaders()
    Dim i As Long

    Application.ScreenUpdating = False
    Debug.Print "Started: " & Now
    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If ActiveSheet.Cells(i, 3) = "HeaderText" Then
            ActiveSheet.Range(i & ":" & i + 1).EntireRow.Delete
        End If
    Next i
    Application.ScreenUpdating = True
    Debug.Print "Finished: " & Now
End Sub

编辑对于一个稍微贫民区但可能更快的解决方案，试试这个：

将以下代码中的常量更改为每行中第一列空白的编号。例如，如果您的数据占用 A-F 列，您希望常数为 7（G 列）。
运行代码，它会将行号放在每个条目旁边。大约需要 30 秒。
按 C 列对整个数据进行排序；这应该需要不到一分钟的时间。
直观地找到“HeaderText”，选择并删除所有行。
按行号列（在我的示例中为“G”）排序。

删除行号列（在我的示例中也是“G”）。

Sub NumberColumns()
    Const BLANK_COLUMN = 7
    Dim i As Long

    For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        ActiveSheet.Cells(i, BLANK_COLUMN) = i
    Next i
    Debug.Print "done"

结束子

【讨论】：

不错，+1。这可能是很慢的 Find 语句
我正在考虑使用过滤器删除行，但 OP 也想删除下一行。恐怕你的编辑解决方案不起作用（或者我错过了什么）
哇，呃，我忘记了这个要求。
这在我的机器上花了大约 25 分钟（我使用了上面提到的原始解决方案）。完美运行，感谢您的宝贵时间！
我强烈建议您不要遍历每个单元格，因为每次调用 Excel 都会影响性能。您可以使用 varray（如我的回答）在很短的时间内完成。

【解决方案2】：

即使它没有完全回答问题，它也可以帮助任何读者......

网络上有几个关于优化 vba 的提示。特别是，您可以这样做：

'turn off some Excel functionality so your code runs faster
'these two are especially very efficient
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'use these if you really need to
Application.DisplayStatusBar = False
Application.EnableEvents = False   'is very efficient if you have ANY event associated with what your macro is going to do

'code goes here

'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True

更多信息请参见here

【讨论】：

Application.ScreenUpdating = False 是最重要的。
另请参阅this answer 使用RAII 进行操作，以便在发生错误时恢复正确的环境。

【解决方案3】：

这个条目有点晚了。它应该比公认的解决方案快约 2 倍。我用我的 XP Excel 2003 计算机和 1 gig 来解决这个问题。

Sub DeleteHeaderText()

    Dim bUnion As Boolean
    Dim d1 As Double
    Dim l As Long
    Dim rDelete As Range
    Dim wks As Worksheet
    Dim vData As Variant

    d1 = Timer
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    bUnion = False
    Set wks = ActiveSheet
    lEnd = ActiveSheet.UsedRange.Rows.Count

    vData = wks.Range("C1:C" & lEnd).Value2

    For l = 1 To lEnd
        If vData(l, 1) = "HeaderText" Then
            If bUnion Then
                Set rDelete = Union(rDelete, wks.Range("A" & l, "A" & l + 1))
            Else
                Set rDelete = wks.Range("A" & l, "A" & l + 1)
                bUnion = True
            End If
            l = l + 1
        End If
    Next l

    Debug.Print Timer() - d1

    rDelete.EntireRow.Delete

    Debug.Print Timer() - d1

End Sub

【讨论】：

【解决方案4】：

我知道这已经晚了，但是如果我了解您的问题，那么您将根据 C 列中的“HeaderText”删除行。因此，由于我没有查看您的数据，因此我创建了自己的数据。我创建了 700,000 行，每 9 行包含“HeaderText”字符串。它删除了约 233k 行（“HeaderText”行 + 前行 + 后行）并在我的计算机上运行了 2.2 秒。试试看！！

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Sub DeleteHeaders()
Dim LastRow As Long
Dim I As Long
Dim WkSheet As Excel.Worksheet
Dim VArray As Variant
Dim NewArray() As String
Dim BooleanArray() As Boolean
Dim NewArrayCount As Long
Dim J As Long
Dim T As Double
Dim DeleteRowCount As Long

T = timeGetTime

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

Set WkSheet = ThisWorkbook.Sheets("Sheet1")

With WkSheet.UsedRange
    LastRow = .Rows.Count
    VArray = .Value
End With
ReDim BooleanArray(0 To UBound(VArray, 1) - 1), NewArray(UBound(VArray, 1) - 1, 0 To UBound(VArray, 2))

For I = 1 To UBound(VArray, 1)
    If InStrB(1, VArray(I, 3), "HeaderText", vbBinaryCompare) <> 0 Then
        BooleanArray(I - 1) = Not BooleanArray(I - 1)
        BooleanArray(I) = Not BooleanArray(I)
        BooleanArray(I + 1) = Not BooleanArray(I + 1)
    End If
Next I

For I = LBound(BooleanArray, 1) To UBound(BooleanArray, 1)
    If BooleanArray(I) = False Then
        For J = LBound(VArray, 2) To UBound(VArray, 2)
            NewArray(NewArrayCount, J - 1) = VArray(I + 1, J)
        Next J
        NewArrayCount = NewArrayCount + 1
    Else
        DeleteRowCount = DeleteRowCount + 1
    End If
Next I

With WkSheet
    .Cells.Delete
    .Range("a1:c" & NewArrayCount).Value = NewArray
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

Erase NewArray, BooleanArray, VArray

MsgBox "Deleted " & DeleteRowCount & " rows." & vbNewLine & vbNewLine & _
"Run time: " & Round((timeGetTime - T) / 1000, 3) & " seconds.", vbOKOnly, "RunTime"

End Sub

【讨论】：

【解决方案5】：

这是一个解决方案，它将在大约 5-20 秒内在 100k 行上运行，具体取决于您拥有的“HeaderText”的出现次数。根据您的要求，它将删除 C 列中带有 HeaderText 的行以及其正上方的行。

更新：正如已经指出的那样，这适用于最大约 100k 的较小数据集，但在较大的数据集上确实不行。回到绘图板:)

 Sub DeleteHeaders()

Application.ScreenUpdating = False
Dim lastRow As Long
Dim varray As Variant

lastRow = Range("C" & Rows.Count).End(xlUp).Row

On Error Resume Next
varray = Range("C1:C" & lastRow).Value
For i = UBound(varray, 1) To 1 Step -1
    If varray(i, 1) = "HeaderText" Then
        Range("C" & i - 1, Range("C" & i)).EntireRow.Delete
        i = i - 1
    End If
Next

Application.ScreenUpdating = True
End Sub

工作原理：通过将整个 C 列转储到一个变体数组中并在 excel 中使用它，您可以大大提高速度。 varray 的布局类似于 (1, 1), (2, 1), (3, 1)，第一个数字是行号，所以您要做的就是向后循环。关键是确保同时删除两行并将 i 再减一。

【讨论】：

我做了一个比较测试，看看是否一次删除所有它们（使用联合先组合范围），发现这样做比一次删除一个快两倍。当然，这是针对 excel 2003 的。我每 100 行使用标题文本进行超过 65000 行。运行您的代码需要 65 秒，运行我的代码需要 33 秒。如果您进行比较测试，请告诉我它是否与我的结果相似。另外，当我运行您的代码时，我将其更改为删除“HeaderText”下方的代码。没关系。
关于这个主题的最后一个想法。使用 .Value2 比 .Value（默认值）更快。 Value2 只是将所有内容作为双打/字符串抓取。 .Value 检查它是否是不同的类型，例如它是双精度数、字符串还是日期等。请参阅fastexcel.wordpress.com/2011/05/25/…
现代机器上的差异很小，它限制了代码的灵活性，所以我总是选择使用 .value :)
是的，你是对的。我想这对于 UDF 会更有效，但对于宏来说这没什么大不了的，除非您必须在不同时间读取数千个大范围。

【解决方案6】：

以下是从 Bill Jelen 书中摘录的代码，这本书非常适合此目的。

使用带有一些逻辑的列（我的代码的列 A）来确定是否应该隐藏行。

在该列的所有适用单元格中使用以下公式

=IF(test TRUE to hide, 1, "keep")

现在使用下面的 VBA

Range("A1:A10000").SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow.Delete

这会一次选择所有具有公式返回数字的行，这正是您要删除的行。无需循环！

【讨论】：

【解决方案7】：

Here 在我的博客上有一个脚本：

示例一：

Sub DelBlankRows()
    Range("D1:D" & Cells _ 
    (Rows.Count,2).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

示例二：

Sub DeleteRowsWithSpecifiedData()
    'Looks in Column D and requires Column IV to be clean
    Columns(4).EntireColumn.Insert

    With Range("D1:D" & ActiveSheet.UsedRange.Rows.Count)
        .FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=""Not Needed"",NA()))"
        .Value = .Value

        On Error Resume Next

        .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
    End With

    On Error GoTo 0

    Columns(4).EntireColumn.Delete
End Sub

【讨论】：