Excel 宏的运行时间越来越长
我的代码可以运行,但问题是运行时间越来越长,每次使用宏时,完成计算所需的时间都在增加。我已经尝试了sytax的各种变体和修改,但由于我对VBA非常陌生,我还没有取得很大的进展。下面是我正在运行的代码(注意,它是作为一个子集运行的,并且Excel 宏的运行时间越来越长,excel,performance,vba,optimization,time,Excel,Performance,Vba,Optimization,Time,我的代码可以运行,但问题是运行时间越来越长,每次使用宏时,完成计算所需的时间都在增加。我已经尝试了sytax的各种变体和修改,但由于我对VBA非常陌生,我还没有取得很大的进展。下面是我正在运行的代码(注意,它是作为一个子集运行的,并且ScreenUpdate=False): 这段代码基本上通过删除整行从数据中删除零值结果。最初,它的运行时间约为12秒,但很快就变为55秒,这已经演变为越来越长的运行时间,现在“快”的运行时间为5分钟。下面是一个电子表格,其中记录了运行时和相应的更改: Runtim
ScreenUpdate=False
):
这段代码基本上通过删除整行从数据中删除零值结果。最初,它的运行时间约为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
我在网上做了一些研究,看起来这可能是Excel在处理大型数据集时遇到的一个已知问题,而我的数据是~51k行,我可以看到这种情况。“…在早期版本的Excel中需要几秒钟才能完成的宏在更高版本的Excel中可能需要几分钟才能完成。或者,如果您再次运行宏,则宏的运行时间可能是第一次的两倍。”来源:
所以我的问题是:有没有办法让它像最初那样运行得更快?为什么会发生这种情况?以下是我通过将数据传输到数组,然后将数组打印到工作表中所做的几项测试的结果。这比任何复制/粘贴以及任何类型的
.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
如果您的电子表格中有公式,我会在开头添加Application.Calculation=xlCalculationManual,并在结尾添加Application.Calculation=xlCalculationAutomatic,以确保您不会在每次删除行时都重新计算。PS:运行时日志中引用的“旧代码”可以在此处找到:是格式重要吗?如果没有,可以尝试使用ADO查询出所需的单元格(字段2和5 0.000)并将记录集粘贴到新的工作表(甚至删除整个范围并仅粘贴查询的结果)?我看到了类似的问题,尽管我的第一次大约25秒,现在大约90秒用于后续运行。问题似乎出现在
.EntireRow.Delete
语句中,这是花费所有时间的地方。@JohnBustos很好的建议。复制过滤范围,然后删除整个范围,然后粘贴。还有一个同样好的建议@DavidZemens。。。停止删除特定行的需要…它肯定运行得更快,但我仍然平均每次运行3:30分钟。我在一台有双四核i7和32千兆内存的机器上进行处理,所以我不认为我的硬件有限。。。不过,我必须消除约20k行数据,这样才能解释时间差吗?运行代码时,第一次运行需要7秒,然后是3:36、3:04、4:14,第五次运行需要5:07。我被难住了,真奇怪。我有I5处理器,而且我很确定我也没有32GB的RAM。。。也许是在被删除的行中。格式化很重要,还是只粘贴值就可以了?另外,我应该补充一点,当我使用随机数据运行代码时,它会在不到一秒钟的时间内运行。我认为这表明运行时依赖于必须删除的行。大卫,你帮了大忙!非常感谢!我想出了一个办法让它工作,所以我想我准备好了。我真的很感谢你的帮助!
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