和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > 100本ノック > 97本目：Accessデータを取得（グループ集計）

97本目：Accessデータを取得（グループ集計）

100本ノック VBA

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：自動席替え（行列と前後左右が全て違うように）

DB1.accdbから取引先&商品で集計出力する。
■出力項目
取引先CD,取引先名,商品CD,商品名,数量合計,金額合計,平均単価,標準単価,最低単価
平均単価は金額/数量(整数に丸め)
最低単価は全取引先での商品の最低単価
■抽出条件
平均単価 > 標準単価
※シートは任意

抽出するAccessデータ

◇ 出題ページはこちら

ソースコード

モジュール一覧

Df_共通定義

Option Explicit

' グループ集計
' (※1)(※2)に数式あり
Public Const R1stグループ集計 = 2
Public Const C1stグループ集計 = 1
Public Enum CNoグループ集計
    取引先CD = C1stグループ集計
    取引先名
    商品CD
    商品名
    数量合計
    金額合計
    平均単価
    標準単価
    最低単価
    取引先_商品
    削除判定
End Enum
Public Const CLastグループ集計 = CNoグループ集計.削除判定

' T売上
Public Const R1stT売上 = 2
Public Const C1stT売上 = 1
Public Enum CNoT売上
    ID = C1stT売上
    取引先CD
    商品CD
    日付
    単価
    数量
End Enum
Public Const CLastT売上 = CNoT売上.数量

' M取引先
Public Const R1stM取引先 = 2
Public Const C1stM取引先 = 1
Public Enum CNoM取引先
    取引先CD = C1stM取引先
    取引先名
End Enum
Public Const CLastM取引先 = CNoM取引先.取引先名

' M商品
Public Const R1stM商品 = 2
Public Const C1stM商品 = 1
Public Enum CNoM商品
    商品CD = C1stM商品
    商品名
    標準単価
End Enum
Public Const CLastM商品 = CNoM商品.標準単価

Op_実行モジュール

Option Explicit

' 実行プロシージャ
Sub ★各Accessテーブルを最新に更新してグループ集計を実行する()

    Call エクセルの自動更新を停止する(False)
    
    Call 各テーブルをAccessファイルから読み込む
    Call グループ集計シートを更新する
    
    Call エクセルの自動更新を開始する

    MsgBox "Accessデータの読込とグループ集計を完了しました。"

End Sub

Pr1_Accessデータの取込

Option Explicit

Sub 各テーブルをAccessファイルから読み込む()

    ' 各シートを初期化
    Call 指定行より下をすべて削除する(WS_T売上, R1stT売上)
    Call 指定行より下をすべて削除する(WS_M取引先, R1stM取引先)
    Call 指定行より下をすべて削除する(WS_M商品, R1stM商品)

    ' Accessファイルから各テーブルを読込
    Dim Accessファイルパス As String
    Accessファイルパス = ThisWorkbook.Path & "\DB1.accdb"
    Call Accessの指定テーブルをセルに出力する(Accessファイルパス, "T売上", WS_T売上.Cells(R1stT売上, 1), False)
    Call Accessの指定テーブルをセルに出力する(Accessファイルパス, "M取引先", WS_M取引先.Cells(R1stM取引先, 1), False)
    Call Accessの指定テーブルをセルに出力する(Accessファイルパス, "M商品", WS_M商品.Cells(R1stM商品, 1), False)

End Sub

Pr2_グループ集計を実行

Option Explicit

' グループ集計の実行
Sub グループ集計シートを更新する()
    
    ' 集計Key「取引先×商品」の取得と数量合計・金額合計の計算
    Call 取引先_商品ごとの数量金額合計を計算して集計シートに出力する

    ' 最低単価の計算
    Call 商品ごとの最低単価を計算して集計シートに反映する

    ' 各種数式計算
    Call 数式計算列を更新する
    
    ' データを必要行だけに抽出
    Call 平均単価が標準単価を下回るデータを削除する

End Sub

' 集計Key「取引先×商品」の取得と数量合計・金額合計の計算
Sub 取引先_商品ごとの数量金額合計を計算して集計シートに出力する()
    
    ' 集計シートの初期化
    Call 指定行より下をすべて削除する(WSグループ集計, R1stグループ集計)
    
    ' 各列のDictionaryを定義
    Dim Dic数量合計 As New Dictionary
    Dim Dic金額合計 As New Dictionary
    
    ' 売上テーブルの全データをループ
    With WS_T売上
        Dim R As Long
        For R = R1stT売上 To Get最終行(WS_T売上)
        
            ' Keyは取引先CD×商品CD
            Dim key取引先_商品: key取引先_商品 _
                = .Cells(R, CNoT売上.取引先CD) & "_" & .Cells(R, CNoT売上.商品CD)
        
            Dic数量合計(key取引先_商品) = Dic数量合計(key取引先_商品) + .Cells(R, CNoT売上.数量)
            Dic金額合計(key取引先_商品) = Dic金額合計(key取引先_商品) _
                                                                + .Cells(R, CNoT売上.数量) * .Cells(R, CNoT売上.単価)
            
        Next
    End With ' 売上テーブルの全データをループ

    ' DictionaryのKey/Itemをセルに出力
    With WSグループ集計
        Call 配列をセルに出力する(.Cells(R1stグループ集計, CNoグループ集計.取引先_商品), Dic数量合計.Keys)
        Call 配列をセルに出力する(.Cells(R1stグループ集計, CNoグループ集計.数量合計), Dic数量合計.Items)
        Call 配列をセルに出力する(.Cells(R1stグループ集計, CNoグループ集計.金額合計), Dic金額合計.Items)
        
        ' Keyを分割
        For R = R1stグループ集計 To Get最終行(WSグループ集計)
            .Cells(R, CNoグループ集計.取引先CD) = Left文字列まで(.Cells(R, CNoグループ集計.取引先_商品), "_")
            .Cells(R, CNoグループ集計.商品CD) = Right文字列まで(.Cells(R, CNoグループ集計.取引先_商品), "_")
        Next
        
    End With
    
End Sub

' 最低単価の計算
Sub 商品ごとの最低単価を計算して集計シートに反映する()

    ' 商品ごとの最低単価をDictionaryで取得
    Dim Dic最低単価 As Dictionary
    Set Dic最低単価 = GetDic商品ごとの最低単価

    ' 全行へ反映
    With WSグループ集計
        Dim R As Long
        For R = R1stグループ集計 To Get最終行(WSグループ集計)
            .Cells(R, CNoグループ集計.最低単価) = Dic最低単価(.Cells(R, CNoグループ集計.商品CD).Value)
        Next
    End With

End Sub
Function GetDic商品ごとの最低単価() As Dictionary
    
    Dim Dic最低単価 As New Dictionary
    
    ' 売上テーブルの全データをループ
    With WS_T売上
        Dim R As Long
        For R = R1stT売上 To Get最終行(WS_T売上)
        
            Dim key商品CD: key商品CD = .Cells(R, CNoT売上.商品CD).Value
            Dim item単価: item単価 = .Cells(R, CNoT売上.単価).Value
        
            ' 新出keyの登録
            If Dic最低単価.Exists(key商品CD) = False Then
                Dic最低単価.Add key商品CD, item単価
                
            ' 既出keyでより安価のitemがあれば更新
            Else
                If Dic最低単価(key商品CD) > item単価 Then
                    Dic最低単価(key商品CD) = item単価
                End If
            End If
            
        Next
    End With ' 売上テーブルの全データをループ
    
    Set GetDic商品ごとの最低単価 = Dic最低単価
    
End Function

' 数式計算(※1)
Sub 数式計算列を更新する()

    Call シート数式で計算する(GetRange指定列のデータ部分(WSグループ集計, CNoグループ集計.取引先名) _
                                        , "=VLOOKUP(A2,M取引先!A:B,2,FALSE)")

    Call シート数式で計算する(GetRange指定列のデータ部分(WSグループ集計, CNoグループ集計.商品名) _
                                        , "=VLOOKUP($C2,M商品!$A:$C,2,FALSE)")

    Call シート数式で計算する(GetRange指定列のデータ部分(WSグループ集計, CNoグループ集計.標準単価) _
                                        , "=VLOOKUP($C2,M商品!$A:$C,3,FALSE)")

    Call シート数式で計算する(GetRange指定列のデータ部分(WSグループ集計, CNoグループ集計.平均単価) _
                                        , "=IF(E2<>0,ROUND(F2/E2,0),0)")

End Sub

' データの抽出（不要行の削除）(※2)
Sub 平均単価が標準単価を下回るデータを削除する()
    
    Call シート数式で計算する(GetRange指定列のデータ部分(WSグループ集計, CNoグループ集計.削除判定) _
                                        , "=G2<=H2")
    
    Call 指令列がTRUEの行を高速削除する(GetRangeフィルターデータ部分(WSグループ集計), CNoグループ集計.削除判定)
    
End Sub

Ut_汎用関数

Option Explicit

' Accessテーブルの取込
Sub Accessの指定テーブルをセルに出力する(Accessファイルパス As String, テーブル名 As String _
    , 出力起点セル As Range, is見出しも出力する As Boolean)
    
    Dim 接続 As Object: Set 接続 = CreateObject("ADODB.Connection")
    接続.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Accessファイルパス & ";"
    
    Dim レコードセット As Object: Set レコードセット = CreateObject("ADODB.Recordset")
    レコードセット.Open "SELECT * FROM " & テーブル名, 接続
    
    ' フィールド名を第1行に出力
    If is見出しも出力する Then
        Dim C As Long
        For C = 1 To レコードセット.Fields.Count
            出力起点セル.Cells(1, C).Value = レコードセット.Fields(C - 1).Name
        Next
    End If
        
    ' 第2行以降に全レコードを出力
    出力起点セル.Cells(IIf(is見出しも出力する, 2, 1), 1).CopyFromRecordset レコードセット
    
    レコードセット.Close: Set レコードセット = Nothing
    接続.Close: Set 接続 = Nothing
    
End Sub

' 指定行より下の削除
Sub 指定行より下をすべて削除する(指定シート As Worksheet, 指定行 As Long)
    With 指定シート
        指定シート.Rows(指定行).Resize(.UsedRange.Rows.Count).Delete
    End With
End Sub

' 最終行の取得
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select
    
    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1
    
    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 最終列の取得
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select
    
    ' エリアの最終列を取得
    Get最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1
    
    ' 列が指定されていればその列の入力最終行を取得
    If R <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(R, Get最終列) = ""
            Get最終列 = Get最終列 - 1
            If Get最終列 < 対象セル範囲.Column Then
                Get最終列 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 行番号の検索
Function Match行番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Dim x: x = CDbl(検索値)
        If Err.Number = 0 Then
            Match行番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Row - 1
            Exit Function
        End If
    End If

    Match行番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Row - 1
    
End Function

' 列番号の検索
Function Match列番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Match列番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Column - 1
    Else
        Match列番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Column - 1
    End If
End Function

' データ件数
Function Countデータ件数(対象シート As Worksheet) As Long
    If 対象シート.AutoFilterMode = False Then Exit Function
    With 対象シート.AutoFilter.Range
        Countデータ件数 = .Rows.Count + .Row - 2
    End With
End Function

' 各列のデータ部分
Function GetRange指定列のデータ部分(対象シート As Worksheet, 対象列 As Long) As Range
    If Countデータ件数(対象シート) = 0 Then Exit Function
    Set GetRange指定列のデータ部分 = 対象シート.Cells(対象シート.AutoFilter.Range.Row + 1, 対象列) _
                                                            .Resize(Countデータ件数(対象シート))
End Function

' フィルターデータ部
Function GetRangeフィルターデータ部分(対象シート As Worksheet) As Range
    Set GetRangeフィルターデータ部分 = Resizeエリアの拡大縮小(対象シート.AutoFilter.Range, -1)
End Function

' エリアの拡大縮小
Function Resizeエリアの拡大縮小(指定エリア As Range, Optional R上方向 As Long = 0, Optional R下方向 As Long = 0 _
    , Optional C左方向 As Long = 0, Optional C右方向 As Long = 0) As Range
    On Error Resume Next
    With 指定エリア
        Set Resizeエリアの拡大縮小 = .Resize(.Rows.Count + R上方向 + R下方向, .Columns.Count + C左方向 + C右方向)
    End With
    Set Resizeエリアの拡大縮小 = Resizeエリアの拡大縮小.Offset(-R上方向, -C左方向)
End Function

' 不要行の削除
Sub 指令列がTRUEの行を高速削除する(データエリア全体 As Range, 判定列 As Long)

    Dim ws対象シート As Worksheet: Set ws対象シート = データエリア全体.Worksheet

    Dim column判定列 As Range
    Set column判定列 = Intersect(データエリア全体, ws対象シート.Columns(判定列))
    If column判定列 Is Nothing Then Exit Sub

    Dim RCount削除行数 As Long
    RCount削除行数 = Fx.CountIf(column判定列, True)
    If RCount削除行数 = 0 Then Exit Sub

    ' ソートしてTRUEを1エリアにまとめる
    データエリア全体.Sort ws対象シート.Cells(1, 判定列)

    ' 第1TRUE行から削除行数分を削除
    Dim R1st削除開始行 As Long
    R1st削除開始行 = Match行番号(True, column判定列)
    ws対象シート.Rows(R1st削除開始行).Resize(RCount削除行数).Delete

End Sub

' シート数式計算
Sub シート数式で計算する(計算エリア As Range, シート数式 As String)
    計算エリア.Formula = シート数式
    計算エリア.Value = 計算エリア.Value
End Sub

' 文字列検索切り出しLeft/Right/Mid
Function Left文字列まで(ByVal 元テキスト As String, ByVal 検索値 As String _
    , Optional is検索値を結果に含む As Boolean = False) As String
    
    Dim instr位置 As Long: instr位置 = InStr(元テキスト, 検索値)
    If instr位置 > 0 Then
        Left文字列まで = Left(元テキスト, instr位置 - 1) & IIf(is検索値を結果に含む, 検索値, "")
    End If
    
End Function
Function Right文字列まで(ByVal 元テキスト As String, ByVal 検索値 As String _
    , Optional is検索値を結果に含む As Boolean = False) As String
    
    Dim instrRev位置 As Long: instrRev位置 = InStrRev(元テキスト, 検索値)
    If instrRev位置 > 0 Then
        Right文字列まで = IIf(is検索値を結果に含む, 検索値, "") _
                                          & Mid(元テキスト, instrRev位置 + Len(検索値))
    End If
    
End Function
Function Mid文字列から文字列(ByVal 元テキスト As String, ByVal 前検索値 As String, ByVal 後検索値 As String _
    , Optional is前検索値を結果に含む As Boolean = False, Optional is後検索値を結果に含む As Boolean = False) As String
    
    Dim instr前値 As Long: instr前値 = InStr(元テキスト, 前検索値)
    If instr前値 = 0 Then Exit Function
    
    Dim instr後値 As Long: instr後値 = InStr(instr前値 + Len(前検索値) + 1, 元テキスト, 後検索値)
    If instr後値 = 0 Then Exit Function
    
    Mid文字列から文字列 = _
        IIf(is前検索値を結果に含む, 前検索値, "") & _
        Mid(元テキスト, instr前値 + Len(前検索値), instr後値 - instr前値 - Len(前検索値)) & _
        IIf(is後検索値を結果に含む, 後検索値, "")
        
End Function

' Dictionaryを新規シートに出力する
Sub Dictionaryを新規シートに出力する(Dic As Dictionary)
    With Workbooks.Add.Worksheets(1)
        Call 配列をセルに出力する(.Range("A1"), Dic.Keys)
        Call 配列をセルに出力する(.Range("B1"), Dic.Items)
    End With
End Sub

' 1次元配列 → セル
Sub 配列をセルに出力する(出力始点セル As Range, Arr出力配列 As Variant _
    , Optional is行方向へ出力 As Boolean = True)

    If UBound(Arr出力配列) = -1 Then Exit Sub

    ' ◇ 要素数が1ならば単セルに出力
    If Count配列の要素数(Arr出力配列) = 1 Then
        出力始点セル.Value = Arr出力配列(0)
    
    ' Transposeで方向指定して出力
    ElseIf is行方向へ出力 Then
        出力始点セル.Resize(Count配列の要素数(Arr出力配列), 1) = Fx.Transpose(Arr出力配列)
    Else
        出力始点セル.Resize(1, Count配列の要素数(Arr出力配列)) = Fx.Transpose(Fx.Transpose(Arr出力配列))
    End If
    
End Sub

' 配列を新規シートに出力する
Sub 配列を新規シートに出力する(Arr)
    Workbooks.Add.Worksheets(1).Range("A1") _
        .Resize(Count配列の要素数(Arr, 1), Count配列の要素数(Arr, 2)) = Arr
End Sub

' 配列の要素数の取得
Function Count配列の要素数(Arr, Optional 次元 = 1) As Long
    Count配列の要素数 = UBound(Arr, 次元) - LBound(Arr, 次元) + 1
End Function

' 配列の次元数の取得
' 参考：https://www.limecode.jp/entry/utility/get-array-dimension
Function Get配列の次元数(Arr As Variant) As Long

    ' 渡された変数が配列ではない場合は0を返すこととする
    If IsArray(Arr) = False Then Get配列の次元数 = 0: Exit Function

    ' エラーが出るまでUBoundを取得してみる
    Dim tmp
    Dim 次元数 As Long: 次元数 = 0
    On Error Resume Next
    Do While Err.Number = 0
        次元数 = 次元数 + 1
        tmp = UBound(Arr, 次元数)
    Loop
    On Error GoTo 0

    ' エラーが出たひとつ前の次元が求める次元数
    Get配列の次元数 = 次元数 - 1
    
End Function

' セルのリストを1次元配列に
' 参考：https://www.limecode.jp/entry/utility/getarray-from-rangeobject
Function GetArrayセルのリストを1次元配列に変換する(セルリスト As Range) As Variant

    ' ◇ 単セル → 値そのまま
    If セルリスト.Cells.Count = 1 Then
        GetArrayセルのリストを1次元配列に変換する = Array(セルリスト.Value)
        Exit Function
    End If

    ' 1列データの時はTransposeで高速化
    If セルリスト.Areas.Count = 1 And セルリスト.Columns.Count = 1 And セルリスト.Count <= 65535 Then
        GetArrayセルのリストを1次元配列に変換する = Fx.Transpose(セルリスト)
        Exit Function
    End If

    ' それ以外は1セルずつ値を格納
    Dim Arr生成配列() As Variant
    ReDim Arr生成配列(1 To セルリスト.Cells.Count) As Variant
    
    Dim i As Long: i = 1
    Dim Cell As Range
    For Each Cell In セルリスト.Cells
        Arr生成配列(i) = Cell.Value
        i = i + 1
    Next

    GetArrayセルのリストを1次元配列に変換する = Arr生成配列

End Function

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' QueryTableによるWEB読み込みの汎用関数
' 参考：https://www.limecode.jp/entry/utility/querytables-import-web-table
Sub QueryTableでWEB上の表を読み込む(出力起点セル As Range _
    , 対象URL As String, Optional テーブルNo As Long = -1 _
    , Optional is書式リンク含む As Boolean = False, Optional is日付に変換する As Boolean = False)

    With 出力起点セル.Worksheet.QueryTables.Add("URL;" & 対象URL, 出力起点セル)
    
        If テーブルNo = -1 Then ' テーブルNo省略時は全テーブルを対象
            .WebSelectionType = xlAllTables
        Else
            .WebTables = xlSpecifiedTables
            .WebTables = テーブルNo
        End If
        .WebFormatting = IIf(is書式リンク含む, xlWebFormattingAll, xlWebFormattingNone)
        .WebDisableDateRecognition = Not (is日付に変換する)
        
        .Refresh BackgroundQuery:=False
        .Delete
    End With

End Sub

' 自動更新の停止
Sub エクセルの自動更新を停止する(isブック計算をOFFに As Boolean _
    , Optional is画面更新をOFFに As Boolean = True _
    , Optional isイベントをOFFに As Boolean = True)
    
    If isブック計算をOFFに Then Application.Calculation = xlCalculationManual
    If is画面更新をOFFに Then Application.ScreenUpdating = False
    If isイベントをOFFに Then Application.EnableEvents = False
    
End Sub

' 自動更新の開始
Sub エクセルの自動更新を開始する()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .StatusBar = False
        .DisplayAlerts = True
    End With
End Sub

解説

本問題はSQLでAccessからデータをとってくる問題で、

  • SQLでマスタの結合や抽出まですべてやってしまう。
  • SQLでは全データをとってくるだけにして、後の処理はVBAと数式でやる。

の2通りのやり方が考えられますが、私の解答では後者を用いました。

グループ集計にはDictionaryを用いており、
ExcelVBA上ではSQLよりもかなり高速で集計を実行することができます。


また「Access指定テーブルをシートに書き出し」を汎用関数化しているので、
一度作れば中身を見なくてもよいという恩恵も得ることができます。

この関数さえ用意しておけばSQLのことは一旦忘れていいということですね。


さてメインロジックの解説ですが、今回は集計のキーが二つ存在し、

  • 集計データは「取引先×商品」ごとにグループ化
  • 最低単価は「商品」ごとに取得

この二つのキーでデータを走査する必要があります。

同時にやるのは可読性を損ないますので、
それぞれ単独のDictionary&Functionで処理しました。


取引先×商品のような複数の要素をキーとして使用する場合は、
その二つを文字列結合してDicitonaryのKeyに使うのが簡単です。


キーの存在判定はExists一発で終わりますし、
なんなら本コードのようにただの代入文オンリーでも処理が書けます。
※ Dictionaryは「Keyがなければその場で作る」という仕様があります。

SUMIFS、COUNTIFS系の処理を簡単に書けるうえ、
処理速度も数百倍になったりしますので是非活用してください。


本解答は配列・Dictionary・Formulaというマクロ高速化トリオをすべて使った、
高速マクロの教科書コードになっています。

データ処理を高速化したい場合は本コードを参考にしてみてください。