Question

我在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

提前致谢！

Answer 1

尝试以下子目录。它从最底部的行循环到顶部，检查第3列的“HeaderText”。如果找到了，则删除该行及其下方的行。在带有2 GB内存的C2D E8500上，每100万行只有超过一分钟，而且行数为100万行。

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对ENTIRE数据进行排序;这应该不到一分钟。

直观地查找“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"

End Sub

Answer 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

Answer 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

Answer 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

Answer 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），第一个数字是行号，所以你要做的就是向后循环。关键是要确保同时删除两行并再减少一行。

Answer 6

以下是Bill Jelen的书中提到的代码，这本书非常出色。

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

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

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

现在使用下面的VBA

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

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

Answer 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

优化Excel VBA代码

7 个答案: