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

以下VBA代码需要很长时间才能执行。我在25分钟前运行了48000行，现在仍在运行。如何缩短执行时间

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

---

关闭屏幕更新以开始。将您的观察结果添加到以下内容中。
如果你认为这不会影响任何事情，你也可以禁用计算

Application.ScreenUpdating = False

your code...

Application.ScreenUpdating = True

编辑：我在这里上传了一个文件-

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

请查看代码以了解详细信息。我想可以进一步优化。
几点提示

• 做一个反向循环
• 获取数组中的单元格内容，使用数组检查值
• 为要删除的行生成字符串
• 分块删除它

---

首先关闭屏幕更新。将您的观察结果添加到以下内容中。
如果你认为这不会影响任何事情，你也可以禁用计算

Application.ScreenUpdating = False

your code...

Application.ScreenUpdating = True

编辑：我在这里上传了一个文件-

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

请查看代码以了解详细信息。我想可以进一步优化。
几点提示

• 做一个反向循环
• 获取数组中的单元格内容，使用数组检查值
• 为要删除的行生成字符串
• 分块删除它

---

最大的问题可能是您循环使用的数据量。我已经更新了您的代码，以创建一个公式来检查是否需要删除该行，然后您可以对该公式结果进行筛选，并一次删除所有行

我已经做了很多评论，既可以帮助您清理代码，也可以帮助您理解我所做的事情。我用

'=>

作为我的评论的开头

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

祝你好运，玩得开心

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

---

最大的问题可能是您循环使用的数据量。我已经更新了您的代码，以创建一个公式来检查是否需要删除该行，然后您可以对该公式结果进行筛选，并一次删除所有行

我已经做了很多评论，既可以帮助您清理代码，也可以帮助您理解我所做的事情。我用

'=>

作为我的评论的开头

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

祝你好运，玩得开心

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

---

其速度如此之慢的原因是您正在迭代每个单元格。下面复制到数组，查找需要删除的行，然后删除。将表4更新到您的表和范围（“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

---

其速度如此之慢的原因是您正在迭代每个单元格。下面复制到数组，查找需要删除的行，然后删除。将表4更新到您的表和范围（“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

---

还是太久了。。。我认为代码在某一点上是无效的，或者设计是有问题的。代码的哪一部分花费了很长时间？您是否可以共享工作簿，其中包含可以运行此宏的虚拟数据？您是否可以确定应该删除的行号，并一次将其全部删除，而不是逐个删除？我打破了代码并检查了表格，只是为了查看代码中的每个条件是否满足。当我调试时，它跳到

结束IF

行。我认为代码在循环中运行是多余的。可能

循环直到（r=RowCount）

是问题所在。无论如何，你在评论中的建议（识别行号并一次性删除它们）似乎是完美的。我该怎么做？@MehperC.Palavuzlar：请查看我的编辑并从链接下载文件。看一看VBA代码，它应该会给你一些提示，特别是关于行删除的分块。Mehper：这个解决方案与现有代码和上面添加的其他建议相比，删除行所需的时间如何？仍然需要很长时间。。。我认为代码在某一点上是无效的，或者设计是有问题的。代码的哪一部分花费了很长时间？您是否可以共享工作簿，其中包含可以运行此宏的虚拟数据？您是否可以确定应该删除的行号，并一次将其全部删除，而不是逐个删除？我打破了代码并检查了表格，只是为了查看代码中的每个条件是否满足。当我调试时，它跳到

结束IF

行。我认为代码在循环中运行是多余的。可能

循环直到（r=RowCount）

是问题所在。无论如何，你在评论中的建议（识别行号并一次性删除它们）似乎是完美的。我该怎么做？@MehperC.Palavuzlar：请查看我的编辑并从链接下载文件。看一看VBA代码，它会给你提示，特别是关于行删除的分块。Mehper：这个解决方案与现有代码和上面添加的其他建议相比，删除行所需的时间如何？你应该使用变体数组或简单的IF测试（手动或使用VBA）可与

AutoFilter

一起使用以删除符合指定条件的行。永远不要使用范围循环-但如果使用，请自底向上删除以避免跳过行。所有变量都会变暗，以确保在每个程序中也使用Option Explicit。默认情况下，通过转到工具>选项>（勾选）要求变量声明来设置此选项。此外，将A、B标注为整数将A标注为变量或对象，您必须分别说明每个变量的类型！此外，如果我没有弄错，VBA不会短路，因此if语句中的所有比较与Or。。。或或将被考虑。也许是公司