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 

Answer 2

关闭屏幕更新以开始。添加您的意见后发布。
如果您认为它不会影响任何事情，您也可以禁用计算。

Application.ScreenUpdating = False 

your code... 

Application.ScreenUpdating = True 

编辑：我已上载这里的文件 - https://dl.dropbox.com/u/24702181/TestDeleteRowsInChunk.xls

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

看看代码的细节。我想它可以进一步优化。
几个提示

• 做一个反向循环。
• 获取数组中的单元格内容，使用数组检查值。
• 为要删除的行建立一个字符串。
• 将其分段删除。

Answer 3

它如此缓慢的原因是你迭代每个单元格。在副本下面的数组中，找到需要删除然后删除的行。更新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