Excel VBA 逆引き集 | マスタ＋集計の合成

Excel VBA
スポンサーリンク

マスタ＋集計の合成

「明細から集計した指標（合計・件数・平均・最新日など）と、マスタの属性（名称・カテゴリ・部署など）を“ひとつの表”にまとめたい」——そのための安全・高速テンプレを、初心者向けにかみ砕いて用意しました。基本は「配列→辞書で集計」「キーでJOIN」「新シートに整えて出力」です。

ワークフローの全体像

  • データ取り込み: 明細とマスタを CurrentRegion で配列に読み込む
  • 集計: キー別に合計・件数・平均・最大/最新などを辞書で計算
  • JOIN: 集計結果にマスタ属性をキーで横付け
  • 出力: 新シートに一括貼り付け、ヘッダー・書式を整える
  • 監査: 未一致キーや重複キーを一覧化してチェック

単一キーで「明細→集計」して「マスタ→JOIN」（基本）

「コード」単位で明細を集計し、名称・カテゴリを横付けして新シートへ出力します。

Option Explicit

Private Function EnsureSheet(ByVal sheetName As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = sheetName
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function

Sub Compose_MasterPlusAggregation_Basic()
    '明細: Sheet("明細") A=コード, B=数量, C=金額, D=日付
    'マスタ: Sheet("マスタ") A=コード, B=名称, C=カテゴリ
    '出力: Sheet("合成結果") … コード, 名称, カテゴリ, 合計金額, 件数, 平均金額, 最新日付

    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")
    Dim vD As Variant: vD = wsD.Range("A1").CurrentRegion.Value
    Dim vM As Variant: vM = wsM.Range("A1").CurrentRegion.Value

    '1) 集計: コード→(sum, cnt, maxDate)
    Dim agg As Object: Set agg = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vD, 1)
        k = UCase$(Trim$(CStr(vD(i, 1))))
        If Len(k) = 0 Then GoTo contD
        Dim amt As Double: amt = CDbl(Val(vD(i, 3)))     '金額
        Dim dte As Date
        If IsDate(vD(i, 4)) Then dte = CDate(vD(i, 4)) Else dte = 0
        If agg.Exists(k) Then
            agg(k)(0) = agg(k)(0) + amt          'sum
            agg(k)(1) = agg(k)(1) + 1            'cnt
            If dte > agg(k)(2) Then agg(k)(2) = dte 'latest
        Else
            agg.Add k, Array(amt, 1, dte)
        End If
contD:
    Next

    '2) マスタ辞書: コード→(名称,カテゴリ)
    Dim dictM As Object: Set dictM = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vM, 1)
        k = UCase$(Trim$(CStr(vM(i, 1))))
        If Len(k) > 0 Then dictM(k) = Array(CStr(vM(i, 2)), CStr(vM(i, 3)))
    Next

    '3) 出力配列（キーの和集合：集計にあるキーをベース）
    Dim keys As Variant: keys = agg.Keys
    Dim n As Long: n = UBound(keys) + 1
    Dim out() As Variant: ReDim out(1 To n + 1, 1 To 7)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "カテゴリ"
    out(1, 4) = "合計金額": out(1, 5) = "件数": out(1, 6) = "平均金額": out(1, 7) = "最新日付"

    Dim r As Long
    For r = 0 To UBound(keys)
        k = keys(r)
        Dim sumAmt As Double: sumAmt = agg(k)(0)
        Dim cnt As Long: cnt = agg(k)(1)
        Dim avgAmt As Double: avgAmt = IIf(cnt > 0, sumAmt / cnt, 0)
        Dim latest As Date: latest = agg(k)(2)

        out(r + 2, 1) = keys(r)
        If dictM.Exists(k) Then
            out(r + 2, 2) = dictM(k)(0)
            out(r + 2, 3) = dictM(k)(1)
        Else
            out(r + 2, 2) = "#N/A"
            out(r + 2, 3) = ""
        End If
        out(r + 2, 4) = sumAmt
        out(r + 2, 5) = cnt
        out(r + 2, 6) = avgAmt
        out(r + 2, 7) = IIf(latest = 0, "", latest)
    Next

    '4) 新シートへ出力＋書式
    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("合成結果", True)
    wsOut.Range("A1").Resize(n + 1, 7).Value = out
    wsOut.Rows(1).Font.Bold = True
    wsOut.Columns.AutoFit
    wsOut.Range("D2:D" & n + 1).NumberFormat = "#,##0"
    wsOut.Range("E2:E" & n + 1).NumberFormat = "0"
    wsOut.Range("F2:F" & n + 1).NumberFormat = "#,##0.00"
    wsOut.Range("G2:G" & n + 1).NumberFormat = "yyyy-mm-dd"
End Sub
VB
  • ポイント
    • 集計指標の自由度: 合計・件数・平均・最新日を同時に計算。
    • JOINの片寄り: 集計に出たキーを基準に横付け（完全結合にしたい場合は後述）。

複数キー（例：コード×年月）で集計＋マスタJOIN

年月別の集計指標を持ちながら、マスタ属性を横付けします。

Sub Compose_MasterPlusAggregation_MultiKey()
    '明細: A=コード, B=日付, C=金額
    'マスタ: A=コード, B=名称, C=カテゴリ
    '出力: コード, 名称, カテゴリ, 年月, 合計, 件数

    Dim vD As Variant: vD = Worksheets("明細").Range("A1").CurrentRegion.Value
    Dim vM As Variant: vM = Worksheets("マスタ").Range("A1").CurrentRegion.Value

    '1) マスタ辞書（コード→(名称,カテゴリ)）
    Dim dictM As Object: Set dictM = CreateObject("Scripting.Dictionary")
    Dim i As Long, kCode As String
    For i = 2 To UBound(vM, 1)
        kCode = UCase$(Trim$(CStr(vM(i, 1))))
        If Len(kCode) > 0 Then dictM(kCode) = Array(CStr(vM(i, 2)), CStr(vM(i, 3)))
    Next

    '2) 集計辞書（key="コード|yyyy-mm" → (sum, cnt)）
    Dim agg As Object: Set agg = CreateObject("Scripting.Dictionary")
    Dim ym As String, key As String
    For i = 2 To UBound(vD, 1)
        kCode = UCase$(Trim$(CStr(vD(i, 1))))
        If Not IsDate(vD(i, 2)) Then GoTo contD
        ym = Format$(CDate(vD(i, 2)), "yyyy-mm")
        key = kCode & "|" & ym
        Dim amt As Double: amt = CDbl(Val(vD(i, 3)))
        If agg.Exists(key) Then
            agg(key)(0) = agg(key)(0) + amt
            agg(key)(1) = agg(key)(1) + 1
        Else
            agg.Add key, Array(amt, 1)
        End If
contD:
    Next

    '3) 出力配列（集計キーを全件）
    Dim keys As Variant: keys = agg.Keys
    Dim n As Long: n = UBound(keys) + 1
    Dim out() As Variant: ReDim out(1 To n + 1, 1 To 6)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "カテゴリ": out(1, 4) = "年月": out(1, 5) = "合計": out(1, 6) = "件数"

    Dim r As Long
    For r = 0 To UBound(keys)
        key = keys(r)
        Dim parts() As String: parts = Split(key, "|")
        kCode = parts(0): ym = parts(1)
        out(r + 2, 1) = kCode
        If dictM.Exists(kCode) Then
            out(r + 2, 2) = dictM(kCode)(0)
            out(r + 2, 3) = dictM(kCode)(1)
        Else
            out(r + 2, 2) = "#N/A": out(r + 2, 3) = ""
        End If
        out(r + 2, 4) = ym
        out(r + 2, 5) = agg(key)(0)
        out(r + 2, 6) = agg(key)(1)
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("合成結果_複数キー", True)
    wsOut.Range("A1").Resize(n + 1, 6).Value = out
    wsOut.Rows(1).Font.Bold = True
    wsOut.Columns.AutoFit
    wsOut.Range("E2:E" & n + 1).NumberFormat = "#,##0"
End Sub
VB
  • ポイント
    • 年月の統一: Format$(date,"yyyy-mm") で型・表記を揃える。
    • 複合キー: "コード|年月" のような安全な区切り文字を使用。

完全結合で「集計＋マスタ」を合成（両側のキーを全部残す）

集計側にあるがマスタに無いコード、マスタにあるが集計に無いコードも可視化します。

Sub Compose_MasterPlusAggregation_FullJoin()
    '前段のBasicで作った agg と dictM を想定（必要ならその場で再作成）
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")
    Dim vD As Variant: vD = wsD.Range("A1").CurrentRegion.Value
    Dim vM As Variant: vM = wsM.Range("A1").CurrentRegion.Value

    '集計辞書（コード→(sum, cnt, avg)）
    Dim agg As Object: Set agg = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vD, 1)
        k = UCase$(Trim$(CStr(vD(i, 1))))
        Dim amt As Double: amt = CDbl(Val(vD(i, 3)))
        If agg.Exists(k) Then
            agg(k)(0) = agg(k)(0) + amt
            agg(k)(1) = agg(k)(1) + 1
        Else
            agg.Add k, Array(amt, 1)
        End If
    Next
    '平均の準備は出力で都度計算

    'マスタ辞書（コード→(名称,カテゴリ)）
    Dim dictM As Object: Set dictM = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vM, 1)
        k = UCase$(Trim$(CStr(vM(i, 1))))
        If Len(k) > 0 Then dictM(k) = Array(CStr(vM(i, 2)), CStr(vM(i, 3)))
    Next

    'キーの和集合
    Dim all As Object: Set all = CreateObject("Scripting.Dictionary")
    For Each k In agg.Keys: all(k) = True: Next
    For Each k In dictM.Keys: all(k) = True: Next

    '出力配列
    Dim n As Long: n = all.Count
    Dim out() As Variant: ReDim out(1 To n + 1, 1 To 6)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "カテゴリ"
    out(1, 4) = "合計金額": out(1, 5) = "件数": out(1, 6) = "平均金額"

    Dim r As Long: r = 2
    Dim key As Variant
    For Each key In all.Keys
        Dim sumAmt As Double: sumAmt = IIf(agg.Exists(key), agg(key)(0), 0)
        Dim cnt As Long: cnt = IIf(agg.Exists(key), agg(key)(1), 0)
        out(r, 1) = key
        out(r, 2) = IIf(dictM.Exists(key), dictM(key)(0), "#N/A")
        out(r, 3) = IIf(dictM.Exists(key), dictM(key)(1), "")
        out(r, 4) = sumAmt
        out(r, 5) = cnt
        out(r, 6) = IIf(cnt > 0, sumAmt / cnt, 0)
        r = r + 1
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("合成結果_完全結合", True)
    wsOut.Range("A1").Resize(n + 1, 6).Value = out
    wsOut.Rows(1).Font.Bold = True
    wsOut.Columns.AutoFit
    wsOut.Range("D2:D" & n + 1).NumberFormat = "#,##0"
    wsOut.Range("E2:E" & n + 1).NumberFormat = "0"
    wsOut.Range("F2:F" & n + 1).NumberFormat = "#,##0.00"
End Sub
VB
  • ポイント
    • 完全結合: キーの和集合で両側の値を横付け、片側欠損は空欄や0で補完。
    • 監査に強い: マスタ未登録の集計キー、集計ゼロのマスタキーが一目でわかる。

見出し名で列特定して壊れない（柔軟版）

列順が変わっても動くように、見出し名で明細列・マスタ列を取得してから同じ流れで合成します。

Private Function FindHeader(ByVal headerRow As Range, ByVal name As String) As Long
    Dim hit As Range
    Set hit = headerRow.Find(What:=name, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindHeader = IIf(hit Is Nothing, 0, hit.Column)
End Function

Sub Compose_MasterPlusAggregation_ByHeaders()
    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = Worksheets("マスタ").Range("A1").CurrentRegion
    Dim vD As Variant: vD = rgD.Value
    Dim vM As Variant: vM = rgM.Value

    '見出しを動的に取得
    Dim cCodeD As Long: cCodeD = FindHeader(rgD.Rows(1), "コード")
    Dim cAmtD As Long:  cAmtD  = FindHeader(rgD.Rows(1), "金額")
    Dim cDateD As Long: cDateD = FindHeader(rgD.Rows(1), "日付")
    Dim cCodeM As Long: cCodeM = FindHeader(rgM.Rows(1), "コード")
    Dim cNameM As Long: cNameM = FindHeader(rgM.Rows(1), "名称")
    Dim cCatM  As Long: cCatM  = FindHeader(rgM.Rows(1), "カテゴリ")
    If cCodeD * cAmtD * cDateD * cCodeM * cNameM * cCatM = 0 Then
        MsgBox "見出し不足": Exit Sub
    End If

    '集計
    Dim agg As Object: Set agg = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vD, 1)
        k = UCase$(Trim$(CStr(vD(i, cCodeD))))
        Dim amt As Double: amt = CDbl(Val(vD(i, cAmtD)))
        Dim dte As Date: dte = IIf(IsDate(vD(i, cDateD)), CDate(vD(i, cDateD)), 0)
        If agg.Exists(k) Then
            agg(k)(0) = agg(k)(0) + amt
            agg(k)(1) = agg(k)(1) + 1
            If dte > agg(k)(2) Then agg(k)(2) = dte
        Else
            agg.Add k, Array(amt, 1, dte)
        End If
    Next

    'マスタ辞書
    Dim dictM As Object: Set dictM = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vM, 1)
        k = UCase$(Trim$(CStr(vM(i, cCodeM))))
        dictM(k) = Array(CStr(vM(i, cNameM)), CStr(vM(i, cCatM)))
    Next

    '出力
    Dim keys As Variant: keys = agg.Keys
    Dim n As Long: n = UBound(keys) + 1
    Dim out() As Variant: ReDim out(1 To n + 1, 1 To 7)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "カテゴリ": out(1, 4) = "合計金額"
    out(1, 5) = "件数": out(1, 6) = "平均金額": out(1, 7) = "最新日付"

    Dim r As Long
    For r = 0 To UBound(keys)
        k = keys(r)
        Dim sumAmt As Double: sumAmt = agg(k)(0)
        Dim cnt As Long: cnt = agg(k)(1)
        out(r + 2, 1) = k
        out(r + 2, 2) = IIf(dictM.Exists(k), dictM(k)(0), "#N/A")
        out(r + 2, 3) = IIf(dictM.Exists(k), dictM(k)(1), "")
        out(r + 2, 4) = sumAmt
        out(r + 2, 5) = cnt
        out(r + 2, 6) = IIf(cnt > 0, sumAmt / cnt, 0)
        out(r + 2, 7) = IIf(agg(k)(2) = 0, "", agg(k)(2))
    Next

    Dim wsOut As Worksheet: Set wsOut = EnsureSheet("合成結果_ByHeaders", True)
    wsOut.Range("A1").Resize(n + 1, 7).Value = out
    wsOut.Rows(1).Font.Bold = True
    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 壊れない: 見出し名で動的に列取得し、現場の列順変動に対応。
    • 早期検知: 見出し不足はメッセージで止めて原因を明確化。

よくある落とし穴と対策

  • キー表記揺れでJOIN漏れ
    • 対策: 正規化: Trim/UCase を徹底。必要なら半角化や記号除去も。
  • 数値が文字列で平均がズレる
    • 対策: 数値化: Val 経由で CDbl に。小数は書式で丸め。
  • 日付の型が混在
    • 対策: 型統一: CDate と Format$ で統一表記。最新日付は DateValue で時刻除去も可。
  • 大規模で遅い
    • 対策: 配列＋辞書＋一括貼付。 前後で ScreenUpdating=False、Calculation=Manual を使うと安定。
  • 完全結合の片側欠損が見えにくい
    • 対策: 明示補完: 文字項目は「#N/A」、数値は0で“欠損”を見える化。

例題で練習

'例1：単一キーで合計・件数・平均・最新日＋マスタを合成
Sub Example_ComposeBasic()
    Compose_MasterPlusAggregation_Basic
End Sub

'例2：コード×年月で集計してマスタを合成
Sub Example_ComposeMultiKey()
    Compose_MasterPlusAggregation_MultiKey
End Sub

'例3：見出し名で列特定して壊れない合成
Sub Example_ComposeByHeaders()
    Compose_MasterPlusAggregation_ByHeaders
End Sub

'例4：集計とマスタの完全結合で両側のキーを全部出す
Sub Example_ComposeFullJoin()
    Compose_MasterPlusAggregation_FullJoin
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました