Цикл занимает слишком много времени, чтобы выполнить

Question

Я хочу сначала поблагодарить вас всех. Я многому научился, задавая вопросы, и от всех вас, отвечающих. Я начинаю привыкать к циклам, но сталкиваюсь с проблемой, когда они выполняются слишком долго. Мой цикл ниже предлагается выполнить два разных расчета. Первый - процентное изменение, а другой - 4-недельный CAGR. Вот код:

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 строк данных и, возможно, еще больше в будущем.

Любая помощь будет принята с благодарностью.

Спасибо

1010 * НКУ *

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