Question

以下VBA代码需要很长时间才能执行。我在25分钟前跑了48,000行并且它仍在运行。如何缩短执行时间？

Sub delrows()

Dim r, RowCount As Long
r = 2

ActiveSheet.Columns(1).Select
RowCount = UsedRange.Rows.Count
userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info")

Rows(RowCount).Delete Shift:=xlUp

' Trim spaces

Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _
    ReplaceFormat:=False

' Delete surplus columns

Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select
    Selection.Delete Shift:=xlToLeft

' Delete surplus rows

Do
    If Left(Cells(r, 1), 1) = "D" _
       Or Left(Cells(r, 1), 1) = "H" _
       Or Left(Cells(r, 1), 1) = "I" _
       Or Left(Cells(r, 1), 2) = "MD" _
       Or Left(Cells(r, 1), 2) = "ND" _
       Or Left(Cells(r, 1), 3) = "MSF" _
       Or Left(Cells(r, 1), 5) = "MSGZZ" _
       Or Len(Cells(r, 1)) = 5 _
       Or Cells(r, 3) = 0 Then
       Rows(r).Delete Shift:=xlUp
    ElseIf Int(Right(Cells(r, 1), 4)) > 4000 Then
       Rows(r).Delete Shift:=xlUp
    Else: r = r + 1
    End If
Loop Until (r = RowCount)

End Sub

Answer 1

最大的问题可能是您正在循环的数据量。我已更新您的代码以创建一个公式来检查是否需要删除该行，然后您可以过滤该公式结果并一次删除所有行。

我做了很多评论，以帮助您清理代码并理解我的所作所为。我在'=>前面写了我的评论。

最后一点，将值加载到数组中也可能有所帮助，但如果您有许多列数据，这可能会更加困难。我没有太多的经验，但我知道这会让世界变得更快！

祝你好运，玩得开心！

Option Explicit

Sub delrows()

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

Dim r As Long, RowCount As Long
r = 2

Dim wks As Worksheet
Set wks = Sheets(1) '=> change to whatever sheet index (or name) you want

'=> rarely a need to select anything in VBA [ActiveSheet.Columns(1).Select]

With wks

    RowCount = .Range("A" & .Rows.Count).End(xlUp).Row '=> as opposed to  [RowCount = UsedRange.Rows.Count], as UsedRange can be misleading
                                                            'NOTE: this also assumes Col A will have your last data row, can move to another column

    userresponse = MsgBox("You have " & RowCount & " rows", vbOKOnly, "Info")

    .Rows(RowCount).Delete Shift:=xlUp

    ' Trim spaces

    '=> rarely a need to select anything in VBA [Columns("A:A").Select]
    .Range("A1:A" & RowCount).Replace What:=" ", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, searchFormat:=False, _
        ReplaceFormat:=False

    ' Delete surplus columns

    '=> rarely a need to select anything in VBA [Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Select]
    .Range("L:T,V:AA,AE:AG,AR:AR,AU:AU,AZ:AZ").Delete Shift:=xlToLeft ' as opposed to Selection.Delete Shift:=xlToLeft

    ' Delete surplus rows

    '=> Now, here is where we help you loop:

    '=> First insert column to the right to capture your data
    .Columns(1).Insert Shift:=xlToRight
    .Range("A1:A" & RowCount).FormulaR1C1 = "=If(OR(Left(RC[1],1) = ""D"",Left(RC[1],1) = ""H"", Left(RC[1],1) = ""I"", Left(RC[1],2) = ""MD"",Left(RC[1],2) = ""ND"",Left(RC[1],3) = ""MSF"",Left(RC[1],5) = ""MSGZZ"",Len(RC[1])=5),""DELETE"",If(Int(Right(RC[1],4)) > 4000,""DELETE"",""""),""""))"

    '=> Now, assuming you something to delete ...
    If Not .Columns(1).Find("DELETE", LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then

        '=> filter and delete
        .Range("A1:A" & RowCount).AutoFilter 1, "DELETE"
        Intersect(.UsedRange, .UsedRange.Offset(1), .Range("A1:A" & RowCount)).SpecialCells(xlCellTypeVisible).EntireRow.Delete

    End If

    '=> Get rid of formula column
    .Columns(1).EntireColumn.Delete

End With

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


End Sub

Answer 2

它是如此缓慢的原因是你在迭代每个单元格。下面复制到一个数组，找到需要删除然后删除的行。将Sheet4更新到工作表和范围（“A2”）。CurrentRegion到您需要的区域：

Dim data() As Variant
Dim count As Double, i As Double, z As Double, arrayCount As Double
Dim deleteRowsFinal As Range
Dim deleteRows() As Double

Application.ScreenUpdating = False

data = Sheet4.Range("A2").CurrentRegion.Value2

    For i = 1 To UBound(data, 1)        
        count = count + 1
        If (data(i, 1) = "D" Or Left(data(i, 1), 1) = "H" Or Left(data(i, 1), 1) = "I" Or Left(data(i, 1), 2) = "MD" _
                Or Left(data(i, 1), 2) = "ND" Or Left(data(i, 1), 3) = "MSF" Or Left(data(i, 1), 5) = "MSGZZ" _
                Or Len(data(i, 1)) = 5 Or data(i, 3) = 0 Or Int(Right(IIf(Cells(i, 1) = vbNullString, 0, Cells(i, 1)), 4)) > 4000) Then

            ReDim Preserve deleteRows(arrayCount)
            deleteRows(UBound(deleteRows)) = count
            arrayCount = arrayCount + 1                
        End If    
    Next i

    Set deleteRowsFinal = Sheet4.Rows(deleteRows(0))

    For z = 1 To UBound(deleteRows)
        Set deleteRowsFinal = Union(deleteRowsFinal, Sheet4.Rows(deleteRows(z)))
    Next z

    deleteRowsFinal.Delete Shift:=xlUp    

Application.ScreenUpdating = True

Answer 3

关闭屏幕更新以开始。添加您的观察结果如下。
如果你认为它没有影响任何东西，你也可以禁用计算。

Application.ScreenUpdating = False

your code...

Application.ScreenUpdating = True

编辑：我在此处上传了一个文件 - https://dl.dropbox.com/u/24702181/TestDeleteRowsInChunk.xls

工作簿已启用宏。
打开后，单击“恢复数据”，然后单击“开始删除”。

详细了解代码。我想它可以进一步优化。
一些提示

做一个反向循环。
获取数组中的单元格内容，使用数组检查值。
为要删除的行构建字符串。
以块的形式删除它。

VBA代码需要很长时间才能执行

3 个答案: