宏的運行時間越來越長

Question

我的代碼可以運行，但是問題在於運行時間越來越長，每次使用宏時完成計算所需的時間都會增加。 我已經嘗試過使用sytax進行各種變體和修改，但是由於我對VBA還是很陌生，所以我並沒有取得太多進步。 這是我正在運行的代碼（注意，它作為一個子集運行，並且ScreenUpdate = False ）：

Public Sub deleteRows()

    Dim lastRow As Long
    Dim rng As Range
    With ActiveSheet
        .AutoFilterMode = False
        lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        '~~> Set the range of interest, no need to include the entire data range
            With .Range("B2:F" & lastRow)
                .AutoFilter Field:=2, Criteria1:="=0.000", Operator:=xlFilterValues
                .AutoFilter Field:=5, Criteria1:="=0.000", Operator:=xlFilterValues
            End With
        .Range("B1:F" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilterMode = False
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End With
    MsgBox Format(Time - start, "hh:mm:ss")

End Sub

該代碼基本上是通過刪除整行從數據中刪除零值結果。 最初，它的運行時間約為12秒，但很快就變成了55秒，此后逐漸延長了運行時間，“快速”現在處於5分鍾范圍內。 下面是一個電子表格，其中列出了運行時的摘要以及所做的相應更改：

Runtime Changes
6:30    None
7:50    None
5:37    Manually stepped through code
7:45    Run with .cells instead of .range("B1:B" & lastRow)
5:21    Run with .Range(B:B)  instead of .range("B1:B" & lastRow)
9:20    Run with application.calculation disabled/enabled, range unchanged
5:35    Run with application.enableEvents disabled/enabled, range unchanged
11:08   Run with application.enableEvents disabled/enabled, Range(B:B)
5:12    None
7:57    Run with Alternative code (old code)
5:45    Range changed to .Range(cells(2,2), Cells(lastRow,2)
10:25   Range changed to .Range(cells(2,2), Cells(lastRow,2), Application.Calculation Disabled/enabled
5:34    Range set to rngB  for .delete portion (range assigned to variable)
9:59    Range set as rng("B1:F" & lastRow)
5:58    Changed system settings for Excel to "High Priority", code reverted to original
9:41    Rerun of old code for comparison
9:26    Reun with change in old code criteria to "0.000"
0:10    Moved SpecialCells……..Delete into 2nd With/End With
5:15    Rerun  SpecialCells……..Delete into 2nd With/End With
11:31   Rerun  SpecialCells……..Delete into 2nd With/End With
11:38   Excel restart; Rerun  SpecialCells……..Delete into 2nd With/End With
5:18    Excel restart; Rerun  SpecialCells……..Delete into 2nd With/End With
6:49    Removed 2nd with 'loop'; all data put into first with statement

我在網上做了一些reasearh，看起來在處理大型數據集時這可能是Excel的一個已知問題，而且由於我的行數約為51,000行，我可以看到情況如何。 “ ...在較早版本的Excel中需要幾秒鍾才能完成的宏在較高版本的Excel中可能需要幾分鍾才能完成。或者，如果第二次運行宏，則該宏可能要花兩倍的時間才能完成。像第一次一樣運行。” 來源： http ： //support.microsoft.com/kb/199​​505

所以我的問題是：是否有任何方法可以像最初那樣使運行速度更快？ 為什么會這樣呢？

Answer 1

這是我通過將數據傳輸到數組然后將數組打印到工作表上所做的幾次測試的結果。 這比任何復制/粘貼以及任何類型的.Delete方法（尤其是在循環中調用）都效率更高。

這些都在大約一秒鍾內執行，並且“刪除”了大約35000+行。

Start 8/6/2014 1:51:14 PM
Start copy data to array 8/6/2014 1:51:14 PM    lastRow=50000
End copy data to array 8/6/2014 1:51:14 PM for 12270 rows
Start print to sheet 8/6/2014 1:51:14 PM
End print to sheet 8/6/2014 1:51:14 PM
Finished 8/6/2014 1:51:14 PM


Start 8/6/2014 1:51:15 PM
Start copy data to array 8/6/2014 1:51:15 PM    lastRow=50000
End copy data to array 8/6/2014 1:51:15 PM for 12339 rows
Start print to sheet 8/6/2014 1:51:15 PM
End print to sheet 8/6/2014 1:51:15 PM
Finished 8/6/2014 1:51:15 PM


Start 8/6/2014 1:51:16 PM
Start copy data to array 8/6/2014 1:51:16 PM    lastRow=50000
End copy data to array 8/6/2014 1:51:16 PM for 12275 rows
Start print to sheet 8/6/2014 1:51:16 PM
End print to sheet 8/6/2014 1:51:16 PM
Finished 8/6/2014 1:51:16 PM


Start 8/6/2014 1:51:17 PM
Start copy data to array 8/6/2014 1:51:17 PM    lastRow=50000
End copy data to array 8/6/2014 1:51:17 PM for 12178 rows
Start print to sheet 8/6/2014 1:51:17 PM
End print to sheet 8/6/2014 1:51:17 PM
Finished 8/6/2014 1:51:17 PM


Start 8/6/2014 1:51:18 PM
Start copy data to array 8/6/2014 1:51:18 PM    lastRow=50000
End copy data to array 8/6/2014 1:51:18 PM for 12130 rows
Start print to sheet 8/6/2014 1:51:18 PM
End print to sheet 8/6/2014 1:51:18 PM
Finished 8/6/2014 1:51:18 PM

這是我用來測試的代碼：

Sub TimerLoop()
Dim i As Integer
For i = 1 To 5
    deleteRows
Next
End Sub

這是修改后的功能； 請注意，我更改了過濾器參數以確保刪除足夠多的行。 在運行之前更改回自己的條件。

Public Sub deleteRows()
Range("B2:F50000").Formula = "=Round(Rand(),2)"

Dim values As Variant
Dim rng As Range
Dim visible As Range
Dim a As Range, r As Range
Dim nextRow As Long
Dim lastRow As Long
Dim totalRows As Long
Dim i As Long

Application.ScreenUpdating = False
Debug.Print "Start " & Now()

    With ActiveSheet
        .AutoFilterMode = False
        lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row

        'Use a range variable instaead of literal construction:
        Set rng = .Range("B2:F" & lastRow)

            With rng
                .AutoFilter Field:=2, Criteria1:=">0.500", Operator:=xlFilterValues
                .AutoFilter Field:=5, Criteria1:=">0.500", Operator:=xlFilterValues
            End With

            'Assign the values to an array:
            Debug.Print "Start copy data to array " & Now() & vbTab & "lastRow=" & lastRow

            Set visible = rng.SpecialCells(xlCellTypeVisible)

            For Each a In visible.Areas
                For Each r In a.Rows
                totalRows = totalRows + 1
                'values(i) = r.Value
                Next
            Next

            ReDim values(1 To totalRows)

            For Each a In visible.Areas
                For Each r In a.Rows
                    i = i + 1
                    values(i) = r.Value
                Next
            Next


            'Turn off autofilter, clear the cells
            .AutoFilterMode = False
            rng.ClearContents
            Debug.Print "End copy data to array " & Now() & " for " & totalRows & " rows"
            'Put the values back in to the sheet, from the array
            Debug.Print "Start print to sheet " & Now()

            rng.Rows(1).Resize(totalRows).Value = _
                Application.Transpose(Application.Transpose(values))

            Debug.Print "End print to sheet " & Now()

        .AutoFilterMode = False
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End With
Debug.Print "Finished " & Now() & vbCrLf & vbCrLf
Application.ScreenUpdating = True
End Sub

Answer 2

如果您的電子表格上有公式，我會在開頭添加Application.Calculation = xlCalculationManual，在結尾添加Application.Calculation = xlCalculationAutomatic，只是為了確保您每次刪除一行時都不會重新計算。