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

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