循环执行时间过长

Question

我首先要感谢大家。我从提问和你们的回答中学到了很多。我开始掌握循环的窍门，但我遇到了一个问题，即它们执行时间太长。下面的循环被要求执行两种不同的计算。第一个是百分比变化，另一个是4周的复合年增长率。这是代码：

Sub POSCAGR()
Dim PSpark As Worksheet
Dim lc As Long
Dim lr As Long
Dim qRng As Range
Dim qCell As Range
Dim rRng As Range
Dim rCell As Range
Dim i As Variant
Dim j As Variant

'-------------------------------
'Set all variables
Set PSpark = Worksheets("POS Trend")
lc = PSpark.Cells(4, Columns.Count).End(xlToLeft).Column
lr = PSpark.Cells(Rows.Count, "A").End(xlUp).Row
Set qRng = PSpark.Range("Q4", ("Q" & lr)) 'range for q
Set rRng = PSpark.Range("R4", ("R" & lr)) 'range for r
'------------------------------
'Calulate WoW changes and 4wk CAGR
On Error Resume Next
For Each qCell In qRng.Cells ' this will calculate the week over week changes
For i = 4 To lr
PSpark.Cells(i, "Q") = ((PSpark.Cells(i, lc).Value / PSpark.Cells(i, lc).Offset(0, -1).Value) - 1)
PSpark.Range("Q4", ("Q" & lr)).NumberFormat = "0.0%"
DoEvents

Next i
Next qCell
On Error GoTo 0
On Error Resume Next
For Each rCell In rRng.Cells ' this will calculate a 4 wk CAGR
For j = 4 To lr
PSpark.Cells(j, "R") = ((PSpark.Cells(j, lc).Value / PSpark.Cells(j, lc).Offset(0, -3).Value) ^ (1 / 3)) - 1
PSpark.Range("R4", ("R" & lr)).NumberFormat = "0.0%"
DoEvents
Next j
Next rCell
On Error GoTo 0

End Sub

这个循环必须遍历大约600行数据，将来可能还会遍历更多。

如有任何帮助，我们将不胜感激。

谢谢，

GCC-

Answer 1

试试这个。

将数据放入数组并一次输入所有单元格会更快，而不是将单个种子分配给单元格。

Sub POSCAGR()
Dim PSpark As Worksheet
Dim lc As Long
Dim lr As Long
Dim qRng As Range
Dim qCell As Range
Dim rRng As Range
Dim rCell As Range
Dim i As Variant
Dim j As Variant
Dim vDB As Variant, vR As Variant
Dim n As Long, c As Integer
'-------------------------------
'Set all variables
Set PSpark = Worksheets("POS Trend")
lc = PSpark.Cells(4, Columns.Count).End(xlToLeft).Column
lr = PSpark.Cells(Rows.Count, "A").End(xlUp).Row
'Set qRng = PSpark.Range("Q4", ("Q" & lr)) 'range for q
Set qRng = PSpark.Range("Q4", ("r" & lr)) 'range for q & r
'Set rRng = PSpark.Range("R4", ("R" & lr)) 'range for r
With PSpark
vDB = .Range("a4", .Cells(lr, lc))
End With
vR = qRng
n = UBound(vDB, 1)
c = UBound(vDB, 2)
'------------------------------
'Calulate WoW changes and 4wk CAGR
For i = 1 To n
vR(i, 1) = vDB(i, c) / vDB(i, c - 1) - 1 ' column q
vR(i, 2) = ((vDB(i, c) / vDB(i, c - 3)) ^ (1 / 3)) - 1 'column r
Next i
qRng.NumberFormatLocal = "0.0%"
qRng = vR

End Sub