Агрегирование почасовых данных о местоположении в ежедневные данные о подразделах для многих столбцов

Я начинаю с почасовой таблицы, в которой около 40 наименований (например, хлеб, ячмень, рогалики, говядина, курица). Цель моего кода — агрегировать числа этой почасовой таблицы с дневными числами, но с разбивкой по подразделам или «типам». Мой единственный способ выделить тип — это использовать таблицу, которая показывает% разбивки типа по местоположению. Эта таблица, однако, соответствует месячной детализации день / ночь (временные рамки). Я решил проблему со словарем для каждого элемента, но расширение его заставляет меня думать, что я делаю это неэффективно.

Я мог бы использовать некоторые мнения о том, как лучше организовать свой код для обработки десятков элементов. Предупреждение, что я никогда не использовал коллекции или классы по незнанию, но я открыт для всего.

* примечание: я преобразовал эти таблицы в формат уценки, используя этот сайт

Пример почасовой таблицы (~ 700 000 строк, ~ 40 столбцов для агрегирования) <Вставлено в B5>

Вот месячная таблица, которая будет использоваться для разбивки дневных чисел. Связь между элементом и множителем — один ко многим, поэтому в этом примере хлеб, ячмень и рогалики разбиваются по множителю 1, а говядина и курица — по множителю 2. Эти прорывы фактически происходят на уровне таймфрейма, поэтому должны произойти до того, как будет агрегирован день.

РАЗРЫВНАЯ ТАБЛИЦА Местоположение по месяцам с указанием% от общего количества по типу + временные рамки <вставлено в L5>

Вот итоговая предполагаемая таблица:

ЕЖЕДНЕВНЫЙ СТОЛ День + Местоположение + Тип <Вставлено S5>

А вот мой текущий рабочий код. Пожалуйста, дайте мне знать свои мысли и не жалейте критики (я знаю, что называю переменные непоследовательно).

Sub hourly_timeframe_to_day_type()
    ' Aggregate a table at the hourly+location+timeframe level
    ' to the daily+location+type level
    
    ' requires "Microsoft Scripting Runtime" reference enabled (Tools>References) to scripting.dictionary objects
    
    '-----------------------------------------------------
    ' Save the table with multipliers and save column header references
    '-----------------------------------------------------
    Dim breakout_array As Variant: breakout_array = ThisWorkbook.Worksheets(1).Range("L5").CurrentRegion
    With Application
        Dim breakout_month_col As Long: breakout_month_col = .Match("Month", .Index(breakout_array, 1, 0), 0)
        Dim breakout_location_col As Long: breakout_location_col = .Match("Location", .Index(breakout_array, 1, 0), 0)
        Dim breakout_type_col As Long: breakout_type_col = .Match("type", .Index(breakout_array, 1, 0), 0)
        Dim breakout_timeframe_col As Long: breakout_timeframe_col = .Match("Timeframe", .Index(breakout_array, 1, 0), 0)
        Dim breakout_multiplier1_col As Long: breakout_multiplier1_col = .Match("Multiplier1", .Index(breakout_array, 1, 0), 0)
        Dim breakout_multiplier2_col As Long: breakout_multiplier2_col = .Match("Multiplier2", .Index(breakout_array, 1, 0), 0)
    End With

    '-----------------------------------------------------
    ' Create dictionaries to track the multiplier using the column references
    '-----------------------------------------------------
    Dim MonthLocationTimeframeType_Multiplier1_dict As Scripting.Dictionary
    Set MonthLocationTimeframeType_Multiplier1_dict = CreateObject("Scripting.Dictionary")
    
    Dim MonthLocationTimeframeType_Multiplier2_dict As Scripting.Dictionary
    Set MonthLocationTimeframeType_Multiplier2_dict = CreateObject("Scripting.Dictionary")
    
    Dim types As Scripting.Dictionary: Set types = CreateObject("Scripting.Dictionary")

    Dim i As Long
    For i = 2 To UBound(breakout_array, 1)
        ' Month + Location + Type + Timeframe
        ' 4/1/2021 + A + x + day
        multiplierkeystring = _
            breakout_array(i, breakout_month_col) & _
            breakout_array(i, breakout_location_col) & _
            breakout_array(i, breakout_type_col) & _
            breakout_array(i, breakout_timeframe_col)
            
        MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring) = breakout_array(i, breakout_multiplier1_col)
        MonthLocationTimeframeType_Multiplier2_dict(multiplierkeystring) = breakout_array(i, breakout_multiplier2_col)
        ' list of possible types
        types(breakout_array(i, breakout_type_col)) = 1
    Next i

    Dim hrly_array As Variant: hrly_array = ThisWorkbook.Worksheets(1).Range("B5").CurrentRegion
    With Application
        'Dim hrly_month_col As Long: hrly_month_col = .Match("Month", .Index(hrly_array, 1, 0), 0)
        Dim hrly_location_col As Long: hrly_location_col = .Match("Location", .Index(hrly_array, 1, 0), 0)
        Dim hrly_timeframe_col As Long: hrly_timeframe_col = .Match("Timeframe", .Index(hrly_array, 1, 0), 0)
        Dim hrly_day_col As Long: hrly_day_col = .Match("Day", .Index(hrly_array, 1, 0), 0)
        
        Dim hrly_bread_col As Long: hrly_bread_col = .Match("bread", .Index(hrly_array, 1, 0), 0)
        Dim hrly_barley_col As Long: hrly_barley_col = .Match("barley", .Index(hrly_array, 1, 0), 0)
        Dim hrly_bagels_col As Long: hrly_bagels_col = .Match("bagels", .Index(hrly_array, 1, 0), 0)
        Dim hrly_beef_col As Long: hrly_beef_col = .Match("beef", .Index(hrly_array, 1, 0), 0)
        Dim hrly_chicken_col As Long: hrly_chicken_col = .Match("chicken", .Index(hrly_array, 1, 0), 0)
        ' ~40 more items
    End With

    Dim DayLocationType_bread_dict As Scripting.Dictionary: Set DayLocationType_bread_dict = CreateObject("Scripting.Dictionary")
    Dim DayLocationType_barley_dict As Scripting.Dictionary: Set DayLocationType_barley_dict = CreateObject("Scripting.Dictionary")
    Dim DayLocationType_bagels_dict As Scripting.Dictionary: Set DayLocationType_bagels_dict = CreateObject("Scripting.Dictionary")
    Dim DayLocationType_beef_dict As Scripting.Dictionary: Set DayLocationType_beef_dict = CreateObject("Scripting.Dictionary")
    Dim DayLocationType_chicken_dict As Scripting.Dictionary: Set DayLocationType_chicken_dict = CreateObject("Scripting.Dictionary")
    ' ~40 more items
    
    ' the first few columns
    Dim day_dict As Scripting.Dictionary: Set day_dict = CreateObject("Scripting.Dictionary")
    Dim location_dict As Scripting.Dictionary: Set location_dict = CreateObject("Scripting.Dictionary")
    Dim type_dict As Scripting.Dictionary: Set type_dict = CreateObject("Scripting.Dictionary")
    
    '-----------------------------------------------------
    ' Turn the hourly into daily type
    '-----------------------------------------------------
    Dim dailykeystring As String
    Dim possible_type As Variant
    
    For Each possible_type In types
        For i = 2 To UBound(hrly_array, 1) ' could be 700,000 rows
            ' define key strings

            multiplierkeystring = _
                DateSerial(Year(hrly_array(i, hrly_day_col)), Month(hrly_array(i, hrly_day_col)), 1) & _
                hrly_array(i, hrly_location_col) & _
                possible_type & _
                hrly_array(i, hrly_timeframe_col)

            dailykeystring = hrly_array(i, hrly_day_col) & hrly_array(i, hrly_location_col) & possible_type
            
            
            ' if this combination exists then continue
            ' and only need to check one dictionary since they all share the same key
            '-------------------------
            If MonthLocationTimeframeType_Multiplier1_dict.Exists(multiplierkeystring) Then
            
                '-------------------------
                ' Headers
                '-------------------------
                day_dict(dailykeystring) = hrly_array(i, hrly_day_col)
                location_dict(dailykeystring) = hrly_array(i, hrly_location_col)
                type_dict(dailykeystring) = possible_type

                '--------------------------------------------------
                ' Hourly+Location+Timeframe to Day+Location+Type
                '--------------------------------------------------
                
                If Not DayLocationType_bread_dict.Exists(dailykeystring) Then
                    '------------------------------------------
                    ' Start Aggregating
                    '------------------------------------------
                    
                    ' Multipier1
                    '-------------------------
                    DayLocationType_bread_dict(dailykeystring) = hrly_array(i, hrly_bread_col) _
                        * MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring)
                        
                    DayLocationType_barley_dict(dailykeystring) = hrly_array(i, hrly_barley_col) _
                        * MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring)
                        
                    DayLocationType_bagels_dict(dailykeystring) = hrly_array(i, hrly_bagels_col) _
                        * MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring)
                    
                    ' Multipier2
                    '-------------------------
                    DayLocationType_beef_dict(dailykeystring) = hrly_array(i, hrly_beef_col) _
                        * MonthLocationTimeframeType_Multiplier2_dict(multiplierkeystring)
                    
                    DayLocationType_chicken_dict(dailykeystring) = hrly_array(i, hrly_chicken_col) _
                        * MonthLocationTimeframeType_Multiplier2_dict(multiplierkeystring)
                        
                    ' ~40 more items
                Else
                    '------------------------------------------
                    ' Continue Aggregate
                    '------------------------------------------
                    
                    ' Multiplier1
                    '-------------------------
                    DayLocationType_bread_dict(dailykeystring) = DayLocationType_bread_dict(dailykeystring) _
                        + hrly_array(i, hrly_bread_col) * MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring)
                        
                    DayLocationType_barley_dict(dailykeystring) = DayLocationType_barley_dict(dailykeystring) _
                        + hrly_array(i, hrly_barley_col) * MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring)

                    DayLocationType_bagels_dict(dailykeystring) = DayLocationType_bagels_dict(dailykeystring) _
                        + hrly_array(i, hrly_bagels_col) * MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring)
                    
                    ' Multiplier2
                    '-------------------------
                    DayLocationType_beef_dict(dailykeystring) = DayLocationType_beef_dict(dailykeystring) _
                        + hrly_array(i, hrly_beef_col) * MonthLocationTimeframeType_Multiplier2_dict(multiplierkeystring)
                        
                    DayLocationType_chicken_dict(dailykeystring) = DayLocationType_chicken_dict(dailykeystring) _
                        + hrly_array(i, hrly_chicken_col) * MonthLocationTimeframeType_Multiplier2_dict(multiplierkeystring)
                        
                    ' ~40 more items
                End If
                
            End If
        Next i
    Next possible_type

    '-----------------------------------------------------
    ' Print the Results
    '-----------------------------------------------------
    Dim daily_rows As Long: daily_rows = DayLocationType_bread_dict.Count
    
    With ThisWorkbook.Worksheets(1).Range("AC6")
    
        ' headers
        '-------------------------
        .Offset(0, 0).Resize(daily_rows, 1) = Application.Transpose(day_dict.Items)
        .Offset(0, 1).Resize(daily_rows, 1) = Application.Transpose(location_dict.Items)
        .Offset(0, 2).Resize(daily_rows, 1) = Application.Transpose(type_dict.Items)
        
        ' items
        '-------------------------
        .Offset(0, 3).Resize(daily_rows, 1) = Application.Transpose(DayLocationType_bread_dict.Items)
        .Offset(0, 4).Resize(daily_rows, 1) = Application.Transpose(DayLocationType_barley_dict.Items)
        .Offset(0, 5).Resize(daily_rows, 1) = Application.Transpose(DayLocationType_bagels_dict.Items)
        .Offset(0, 6).Resize(daily_rows, 1) = Application.Transpose(DayLocationType_beef_dict.Items)
        .Offset(0, 7).Resize(daily_rows, 1) = Application.Transpose(DayLocationType_chicken_dict.Items)
        
        ' ~40 more items
        '-------------------------
        
    End With
    
End Sub

Использование класса для хранения данных, относящихся к различным элементам, поможет устранить множество Около дублированный код в вашей подпрограмме. Подход состоит в том, что вы определяете класс для хранения данных и объектов, релевантных и уникальных для каждого элемента (хлеб, едва, курица и т. Д.). Это позволит вам работать с петлями.

Итак, класс вроде (TableItem) ниже:

    Option Explicit

    Private mBreakoutTableColumn As Long
    Private mResultOffsetColumn As Long
    Private mItemName As String
    Private mMultipliers As Dictionary
    Private myDict As Dictionary

    Private Sub Class_Initialize()
        Set myDict = New Dictionary
    End Sub

    Public Property Get DailyRowCount() As Long
        DailyRowCount = myDict.Count
    End Property

    Public Property Get ItemName() As String
        ItemName = mItemName
    End Property
    Public Property Let ItemName(ByVal RHS As String)
        mItemName = RHS
    End Property

    Public Property Get BreakoutTableColumn() As Long
        BreakoutTableColumn = mBreakoutTableColumn
    End Property

    Public Property Let BreakoutTableColumn(ByVal RHS As Long)
        mBreakoutTableColumn = RHS
    End Property

    Public Property Get ResultOffsetColumn() As Long
        ResultOffsetColumn = mResultOffsetColumn
    End Property

    Public Sub LoadUniqueContent(ByVal identifier As String, ByVal colNumber As Long, ByVal multipliers As Dictionary, ByVal rsltOffsetColumn As Long)
        ItemName = identifier
        BreakoutTableColumn = colNumber
        mResultOffsetColumn = rsltOffsetColumn
        Set mMultipliers = multipliers
    End Sub

    Public Function MultiplierKeyExists(ByVal multiplierKey As String) As Boolean
        MultiplierKeyExists = mMultipliers.Exists(multiplierKey)
    End Function

    Public Sub Aggregate(ByVal dailykeystring, ByVal multiplierkeystring, ByVal valToAggregate As Double)
        If Not myDict.Exists(dailykeystring) Then
            myDict(dailykeystring) = valToAggregate _
                * mMultipliers(multiplierkeystring)
        Else
            myDict(dailykeystring) = myDict(dailykeystring) + valToAggregate _
                * mMultipliers(multiplierkeystring)
        End If
    End Sub

    Public Function TransposeItem() As Variant
        TransposeItem = Application.Transpose(myDict.Items)
    End Function

Делает возможным использование петель. (Изменения начинаются примерно в середине подпрограммы)

    Option Explicit

    Sub hourly_timeframe_to_day_type()
        ' Aggregate a table at the hourly+location+timeframe level
        ' to the daily+location+type level
        
        ' requires "Microsoft Scripting Runtime" reference enabled (Tools>References) to scripting.dictionary objects
        
        '-----------------------------------------------------
        ' Save the table with multipliers and save column header references
        '-----------------------------------------------------
        
        'Dim breakout_array As Variant: breakout_array = ThisWorkbook.Worksheets("Breakout").Range("L5").CurrentRegion
        Dim breakout_array As Variant: breakout_array = ThisWorkbook.Worksheets("Breakout").Range("A1:F17")
        With Application
            Dim breakout_month_col As Long: breakout_month_col = .Match("Month", .Index(breakout_array, 1, 0), 0)
            Dim breakout_location_col As Long: breakout_location_col = .Match("Location", .Index(breakout_array, 1, 0), 0)
            Dim breakout_type_col As Long: breakout_type_col = .Match("type", .Index(breakout_array, 1, 0), 0)
            Dim breakout_timeframe_col As Long: breakout_timeframe_col = .Match("Timeframe", .Index(breakout_array, 1, 0), 0)
            Dim breakout_multiplier1_col As Long: breakout_multiplier1_col = .Match("Multiplier1", .Index(breakout_array, 1, 0), 0)
            Dim breakout_multiplier2_col As Long: breakout_multiplier2_col = .Match("Multiplier2", .Index(breakout_array, 1, 0), 0)
        End With

        '-----------------------------------------------------
        ' Create dictionaries to track the multiplier using the column references
        '-----------------------------------------------------
        Dim MonthLocationTimeframeType_Multiplier1_dict As Scripting.Dictionary
        Set MonthLocationTimeframeType_Multiplier1_dict = CreateObject("Scripting.Dictionary")
        
        Dim MonthLocationTimeframeType_Multiplier2_dict As Scripting.Dictionary
        Set MonthLocationTimeframeType_Multiplier2_dict = CreateObject("Scripting.Dictionary")
        
        Dim types As Scripting.Dictionary: Set types = CreateObject("Scripting.Dictionary")

        Dim multiplierkeystring As String
        
        Dim i As Long
        For i = 2 To UBound(breakout_array, 1)
            ' Month + Location + Type + Timeframe
            ' 4/1/2021 + A + x + day
            multiplierkeystring = _
                breakout_array(i, breakout_month_col) & _
                breakout_array(i, breakout_location_col) & _
                breakout_array(i, breakout_type_col) & _
                breakout_array(i, breakout_timeframe_col)
                
            MonthLocationTimeframeType_Multiplier1_dict(multiplierkeystring) = breakout_array(i, breakout_multiplier1_col)
            MonthLocationTimeframeType_Multiplier2_dict(multiplierkeystring) = breakout_array(i, breakout_multiplier2_col)
            ' list of possible types
            types(breakout_array(i, breakout_type_col)) = 1
        Next i
        
        
    '*******************************CHANGES START HERE**********************************

        'Load items into a collection
        Dim tblItems As Collection
        Set tblItems = New Collection
        
        'Dim hrly_array As Variant: hrly_array = ThisWorkbook.Worksheets(1).Range("B5").CurrentRegion
        Dim hrly_array As Variant: hrly_array = ThisWorkbook.Worksheets("Hourly").Range("A1:I17")
        With Application
            Dim hrly_location_col As Long: hrly_location_col = .Match("Location", .Index(hrly_array, 1, 0), 0)
            Dim hrly_timeframe_col As Long: hrly_timeframe_col = .Match("Timeframe", .Index(hrly_array, 1, 0), 0)
            Dim hrly_day_col As Long: hrly_day_col = .Match("Day", .Index(hrly_array, 1, 0), 0)
        End With
            
        'defaultTableItem is used for extracting data common to all items without having to access the collection
        Dim defaultTableItem As TableItem
        Set defaultTableItem = CreateTableItem("bread", hrly_array, MonthLocationTimeframeType_Multiplier1_dict, 3)
        tblItems.Add defaultTableItem
        
        Dim tblItem As TableItem
        Set tblItem = CreateTableItem("barley", hrly_array, MonthLocationTimeframeType_Multiplier1_dict, 4)
        tblItems.Add tblItem
        
        Set tblItem = CreateTableItem("bagels", hrly_array, MonthLocationTimeframeType_Multiplier1_dict, 5)
        tblItems.Add tblItem
        
        Set tblItem = CreateTableItem("beef", hrly_array, MonthLocationTimeframeType_Multiplier2_dict, 6)
        tblItems.Add tblItem
        
        Set tblItem = CreateTableItem("chicken", hrly_array, MonthLocationTimeframeType_Multiplier2_dict, 7)
        tblItems.Add tblItem
        ' ~40 more items
        

        'Dim DayLocationType_bread_dict As Scripting.Dictionary: Set DayLocationType_bread_dict = CreateObject("Scripting.Dictionary")
        'Dim DayLocationType_barley_dict As Scripting.Dictionary: Set DayLocationType_barley_dict = CreateObject("Scripting.Dictionary")
        'Dim DayLocationType_bagels_dict As Scripting.Dictionary: Set DayLocationType_bagels_dict = CreateObject("Scripting.Dictionary")
        'Dim DayLocationType_beef_dict As Scripting.Dictionary: Set DayLocationType_beef_dict = CreateObject("Scripting.Dictionary")
        'Dim DayLocationType_chicken_dict As Scripting.Dictionary: Set DayLocationType_chicken_dict = CreateObject("Scripting.Dictionary")
        ' ~40 more items REMOVED
        
        ' the first few columns
        Dim day_dict As Scripting.Dictionary: Set day_dict = CreateObject("Scripting.Dictionary")
        Dim location_dict As Scripting.Dictionary: Set location_dict = CreateObject("Scripting.Dictionary")
        Dim type_dict As Scripting.Dictionary: Set type_dict = CreateObject("Scripting.Dictionary")
        
        '-----------------------------------------------------
        ' Turn the hourly into daily type
        '-----------------------------------------------------
        Dim dailykeystring As String
        Dim possible_type As Variant
        
        For Each possible_type In types
            For i = 2 To UBound(hrly_array, 1) ' could be 700,000 rows
                ' define key strings

                multiplierkeystring = _
                    DateSerial(Year(hrly_array(i, hrly_day_col)), Month(hrly_array(i, hrly_day_col)), 1) & _
                    hrly_array(i, hrly_location_col) & _
                    possible_type & _
                    hrly_array(i, hrly_timeframe_col)

                dailykeystring = hrly_array(i, hrly_day_col) & hrly_array(i, hrly_location_col) & possible_type
                
                Aggregate tblItems, dailykeystring, multiplierkeystring, hrly_array, i
                '~40+ lines REMOVED
                
                ' if this combination exists then continue
                ' and only need to check one dictionary since they all share the same key
                '-------------------------
                If defaultTableItem.MultiplierKeyExists(multiplierkeystring) Then
                
                    '-------------------------
                    ' Headers
                    '-------------------------
                    day_dict(dailykeystring) = hrly_array(i, hrly_day_col)
                    location_dict(dailykeystring) = hrly_array(i, hrly_location_col)
                    type_dict(dailykeystring) = possible_type
                    
                End If
            Next i
        Next possible_type

        '-----------------------------------------------------
        ' Print the Results
        '-----------------------------------------------------
        Dim daily_rows As Long
        daily_rows = defaultTableItem.DailyRowCount
        
        'With ThisWorkbook.Worksheets(1).Range("AC6")
        With ThisWorkbook.Worksheets("Daily").Range("A1")
        
            ' headers
            '-------------------------
            .Offset(0, 0).Resize(daily_rows, 1) = Application.Transpose(day_dict.Items)
            .Offset(0, 1).Resize(daily_rows, 1) = Application.Transpose(location_dict.Items)
            .Offset(0, 2).Resize(daily_rows, 1) = Application.Transpose(type_dict.Items)
            
            ' items ~40+ lines removed
            '-------------------------
            Dim tblItm As Variant
            For Each tblItm In tblItems
                Set tblItem = tblItm
                .Offset(0, tblItem.ResultOffsetColumn).Resize(daily_rows, 1) = tblItem.TransposeItem()
            Next
        End With
        
    End Sub
    Private Sub Aggregate(ByVal itemsCollection As Collection, ByVal dailykeystring As String, ByVal multiplierkeystring As String, ByRef hrlyArray As Variant, ByVal idx As Long)
        
        Dim tblItem As TableItem
        Dim itm As Variant
        For Each itm In itemsCollection
            Set tblItem = itm
            tblItem.Aggregate dailykeystring, multiplierkeystring, hrlyArray(idx, tblItem.BreakoutTableColumn)
        Next
    End Sub

    Private Function CreateTableItem(ByVal identifier As String, ByRef hrly_array As Variant, ByVal multipliers As Dictionary, ByVal rsltOffsetColumn As Long) As TableItem
        Dim tblItem As TableItem
        Set tblItem = New TableItem
        Dim breakoutCol As Long
        breakoutCol = Application.Match(identifier, Application.Index(hrly_array, 1, 0), 0)

        tblItem.LoadUniqueContent identifier, breakoutCol, multipliers, rsltOffsetColumn
        Set CreateTableItem = tblItem
    End Function

Как видите, по-прежнему необходимы более 40 строк для настройки каждого экземпляра класса. Как только это будет сделано, код сможет работать с Collection в целом.