macros观运行时间越来越长
我的代码工作正常，但问题在于运行时间越来越长，每次使用macros时都需要花费更多时间来完成计算。 我已经尝试了各种各样的变化和修改，但是由于我对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分钟的范围内“快”。 下面是一个电子表格，其中logging了运行时间和相应的更改：
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处理大型数据集时的一个已知问题，而我的大约51k行，我可以看到这是怎么回事。 “…在较早版本的Excel中需要几秒钟才能完成的macros可能需要几分钟才能在Excel的更高版本中完成。或者，如果再次运行一个macros，macros可能需要两倍的时间按照第一次运行。“ 来源： http : //support.microsoft.com/kb/199505
所以我的问题是：有没有办法让这个运行更快，就像最初那样？ 为什么发生这种情况？
下面是我通过将数据传输到数组，然后将数组打印到工作表所做的几个testing的结果。 这比任何复制/粘贴以及任何types的.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
这里是我用来testing它的代码：
Sub TimerLoop() Dim i As Integer For i = 1 To 5 deleteRows Next End Sub
这是修改的function; 请注意，我更改了filter参数，以确保我将删除足够多的行数。 运行之前，请回到您自己的标准。
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
如果您的电子表格中有公式，我会在开始处添加Application.Calculation = xlCalculationManual，并在最后添加Application.Calculation = xlCalculationAutomatic，以确保每次删除行时都不会重新计算。