循环执行时间太长

Question

I want to first thank you all. I have learned a lot from asking question and from you all answering. I am starting to get the hang of loops but I am running into an issue where they are taking too long to execute. My loop below is being asked to perform two different calculations. The first one is a percent change and the other is a 4 week CAGR. Here is the code:

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

This loop has to go through about 600 rows of data and potentially more in the future.

Any help would be greatly appreciated.

Thanks,

GCC

Answer 1

Try this.

Rather than assigning a single seed to a cell, it is faster to put the data into an array and enter it into all cells at once.

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