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