VBA: Как интегрировать Scripting.Dictionary с макросом Lookup (проверить диапазон, записать критерии соответствия, выполнить цикл) при большом количестве строк

Question

Я новичок в использовании словаря с VBA в Excel

У меня есть таблица с 500k + строк, отсортированных в последовательности отметок времени

Я написал макрос, который должен в каждом листе агрегировать каждыйпять минут периода (пять строк) и напишите первое значение diff.от нуля.

Однако это очень неэффективно, поскольку он проходит по всем 500k + строкам.Я использовал только Scripting.Dictionary вместо VLOOKUP, и он работает менее чем за 20 секунд.Есть ли у вас какие-либо идеи, как я мог бы объединить два макроса ниже или указать мне онлайн-ресурс?

например, Таблица 1

TimeStamp | Value
00:00     | 0
00:01     | 0
00:02     | 1.004
00:03     | 1.002
00:04     | 1.006
00:05     | 1.011

Таблица 2

TimeStamp | Value
00:00     | 1.004
00:05     | 1.011

Макрос агрегации

Sub Macro1()

    Dim x As Integer
    Sheets("New").Select
    i = 2
    Counter = 0
    Sheets("5_min").Select
    FirstOfFive = 2
    Range("A1").Select
    LastRow = Selection.End(xlDown).Row
    Sheets("Main_1min").Select


    For J = FirstOfFive To Last Row

        For i = i To i + 4
        Cells(i, 1).Select
        If Cells(i, 1).Value = 0 Then
        ActiveCell.Offset(1, 0).Select
        Counter = Counter + 1
        Else
        StartVal = Selection.Value
        GoTo 2
        End If

        Next i

    2
    Sheets("5_min").Select
    Cells(J, 2).Value = StartVal
    Sheets("Main_1min").Select
    i = i + 5 - Counter
    Counter = 0
    Next J


End Sub

Макрос поиска

Sub DictionaryVLookup()

    Dim x, x2, y, y2()
    Dim i As Long
    Dim dict As Object
    Dim LastRow As Long, shtNew As Worksheet, shtOld As Worksheet

    Set shtNew = Worksheets("Main_1min")
    Set shtOld = Worksheets("Old")
    Set dict = CreateObject("Scripting.Dictionary")

    'get the lookup dictionary from Old
    With shtOld
        LastRow = .Range("E" & Rows.Count).End(xlUp).Row
        x = .Range("A2:A" & LastRow).Value
        x2 = .Range("C2:C" & LastRow).Value
        For i = 1 To UBound(x, 1)
            dict.Item(x(i, 1)) = x2(i, 1)
        Next i
    End With

    'map the values
    With shtNew
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        y = .Range("A2:A" & LastRow).Value    'looks up to this range
        ReDim y2(1 To UBound(y, 1), 1 To 1)   '<< size the output array
        For i = 1 To UBound(y, 1)
            If dict.Exists(y(i, 1)) Then
                y2(i, 1) = dict(y(i, 1))
            Else
                y2(i, 1) = "0"
            End If
        Next i
        .Range("C2:C" & LastRow).Value = y2  '<< place the output on the sheet
    End With

End Sub