Excel VBA 逆引き集 | マスタとの集計統合

Excel VBA
スポンサーリンク

マスタとの集計統合

「明細データにマスタの属性を付けてから集計したい」「コードから正式名称へ置き換えて集計したい」——VLOOKUP相当、INDEX/MATCH相当、辞書での高速ジョイン、未登録キーの扱いまで、初心者でも壊れないテンプレをまとめました。

目的と選び方

  • 明細にマスタ項目を付ける（1対多の参照）: 辞書でキー→レコードを引く（高速・頑丈）
  • 関数で手軽に付与: WorksheetFunction.VLookup / Index + Match（少量・簡単）
  • マスタ属性で集計したい: マスタでカテゴリを付与→辞書/pivotでグループ集計
  • 未登録キー対策と監査: 未一致をフラグ、一覧を作って追加依頼へ

基本テンプレ：辞書で「コード→名称・カテゴリ」を付与（高速ジョイン）

'明細シート：A=コード, B=日付, C=金額
'マスタシート：A=コード, B=正式名称, C=カテゴリ
Sub JoinMaster_WithDictionary()
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")

    'マスタを配列→辞書化（キー：コード）
    Dim rgM As Range: Set rgM = wsM.Range("A1").CurrentRegion
    Dim vm As Variant: vm = rgM.Value

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String

    For i = 2 To UBound(vm, 1)
        key = Trim$(CStr(vm(i, 1)))                 'コード
        If Len(key) > 0 Then
            '名称・カテゴリを格納（配列で保持）
            dict(key) = Array(CStr(vm(i, 2)), CStr(vm(i, 3)))
        End If
    Next

    '明細側を配列に読み込み→名称・カテゴリを列追加して書き戻し
    Dim rgD As Range: Set rgD = wsD.Range("A1").CurrentRegion
    Dim vd As Variant: vd = rgD.Value

    '出力列ヘッダー（末尾2列追加：名称・カテゴリ）
    Dim out() As Variant: ReDim out(1 To UBound(vd, 1), 1 To UBound(vd, 2) + 2)
    Dim r As Long, c As Long

    'ヘッダーコピー＋追加
    For c = 1 To UBound(vd, 2): out(1, c) = vd(1, c): Next
    out(1, UBound(vd, 2) + 1) = "名称"
    out(1, UBound(vd, 2) + 2) = "カテゴリ"

    '明細行に付与
    For r = 2 To UBound(vd, 1)
        For c = 1 To UBound(vd, 2)
            out(r, c) = vd(r, c)
        Next
        key = Trim$(CStr(vd(r, 1)))                 'A列コード
        If dict.Exists(key) Then
            out(r, UBound(vd, 2) + 1) = dict(key)(0)
            out(r, UBound(vd, 2) + 2) = dict(key)(1)
        Else
            out(r, UBound(vd, 2) + 1) = "#N/A"
            out(r, UBound(vd, 2) + 2) = "#N/A"
        End If
    Next

    '書き戻し（元表をクリアして上書き）
    wsD.Range("A1").Resize(UBound(out, 1), UBound(out, 2)).Value = out
End Sub
VB
  • ポイント:
    • 配列＋辞書で高速: セル往復ゼロ。10万行規模でも現実的。
    • 未一致は「#N/A」: 後で監査しやすい。必要なら別列に「未登録」フラグを追加。

関数版：VLOOKUP相当をそのまま使う（少量・簡単）

Sub JoinMaster_WithVLookup()
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")

    Dim lastD As Long: lastD = wsD.Cells(wsD.Rows.Count, "A").End(xlUp).Row
    Dim tblM As Range: Set tblM = wsM.Range("A1").CurrentRegion  'A:C

    '名称をD列、カテゴリをE列に付与
    With wsD.Range("D2:D" & lastD)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC1," & tblM.Address(True, True, xlA1, True) & ",2,FALSE),""#N/A"")"
        .Value = .Value  '値化
    End With
    With wsD.Range("E2:E" & lastD)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC1," & tblM.Address(True, True, xlA1, True) & ",3,FALSE),""#N/A"")"
        .Value = .Value
    End With
    wsD.Range("D1").Value = "名称": wsD.Range("E1").Value = "カテゴリ"
End Sub
VB
  • ポイント:
    • 値化して式撤去: 再計算負荷を避けて安定運用。
    • A1参照の絶対アドレス: Address(…, True)で参照がズレない。

INDEX/MATCH相当：列の増減に強い

Sub JoinMaster_WithIndexMatch()
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")

    Dim lastD As Long: lastD = wsD.Cells(wsD.Rows.Count, "A").End(xlUp).Row
    Dim rngKey As Range: Set rngKey = wsM.Range("A:A")
    Dim rngName As Range: Set rngName = wsM.Range("B:B")
    Dim rngCat As Range: Set rngCat = wsM.Range("C:C")

    With wsD.Range("D2:D" & lastD)
        .FormulaR1C1 = "=IFERROR(INDEX(" & rngName.Address(True, True, xlA1, True) & ",MATCH(RC1," & rngKey.Address(True, True, xlA1, True) & ",0)),""#N/A"")"
        .Value = .Value
    End With
    With wsD.Range("E2:E" & lastD)
        .FormulaR1C1 = "=IFERROR(INDEX(" & rngCat.Address(True, True, xlA1, True) & ",MATCH(RC1," & rngKey.Address(True, True, xlA1, True) & ",0)),""#N/A"")"
        .Value = .Value
    End With
    wsD.Range("D1").Value = "名称": wsD.Range("E1").Value = "カテゴリ"
End Sub
VB
  • ポイント:
    • 列順が変わっても安全: 参照範囲を列単位に。VLOOKUPの列番号ズレ問題を回避。

統合後の「カテゴリ別集計」（マスタ属性でグループ化）

'明細A=コード, C=金額、マスタでカテゴリ付けしてから集計
Sub Aggregate_ByMasterCategory()
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")

    '1) マスタ辞書：コード→カテゴリ
    Dim vm As Variant: vm = wsM.Range("A1").CurrentRegion.Value
    Dim dictCat As Object: Set dictCat = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vm, 1)
        key = Trim$(CStr(vm(i, 1)))
        If Len(key) > 0 Then dictCat(key) = CStr(vm(i, 3))
    Next

    '2) 明細を読み→カテゴリで合計/件数
    Dim vd As Variant: vd = wsD.Range("A1").CurrentRegion.Value
    Dim sumMap As Object: Set sumMap = CreateObject("Scripting.Dictionary")
    Dim cntMap As Object: Set cntMap = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(vd, 1)
        key = Trim$(CStr(vd(i, 1)))                'コード
        Dim cat As String
        If dictCat.Exists(key) Then cat = dictCat(key) Else cat = "未登録"
        If Not sumMap.Exists(cat) Then sumMap.Add cat, 0#: cntMap.Add cat, 0
        sumMap(cat) = sumMap(cat) + Val(vd(i, 3))
        cntMap(cat) = cntMap(cat) + 1
    Next

    '3) 出力（シート「集計」へ）
    Dim wsO As Worksheet: Set wsO = Worksheets("集計")
    wsO.Range("A1:C1").Value = Array("カテゴリ", "合計金額", "件数")
    Dim k As Variant, rOut As Long: rOut = 2
    For Each k In sumMap.Keys
        wsO.Cells(rOut, 1).Value = k
        wsO.Cells(rOut, 2).Value = sumMap(k)
        wsO.Cells(rOut, 3).Value = cntMap(k)
        rOut = rOut + 1
    Next
End Sub
VB
  • ポイント:
    • 「未登録」バケット: マスタ未一致を落とさず可視化。
    • 追加軸も簡単: キーを「カテゴリ|年月」などへ拡張すれば多軸集計が一撃。

未登録キーの監査リストを作る（運用必須）

Sub List_UnmatchedKeys()
    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

    'マスタのキー集合
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vm, 1)
        key = Trim$(CStr(vm(i, 1)))
        If Len(key) > 0 Then dict(key) = True
    Next

    '未一致キーを一意に収集
    Dim miss As Object: Set miss = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vd, 1)
        key = Trim$(CStr(vd(i, 1)))
        If Len(key) > 0 And Not dict.Exists(key) Then miss(key) = True
    Next

    '出力
    Dim wsO As Worksheet: Set wsO = Worksheets("未登録")
    wsO.Cells.Clear
    wsO.Range("A1").Value = "未登録コード"
    Dim r As Long: r = 2
    Dim k As Variant
    For Each k In miss.Keys
        wsO.Cells(r, 1).Value = k
        r = r + 1
    Next
End Sub
VB
  • ポイント:
    • 監査の見える化: マスタ整備の抜け漏れを定期的に洗い出す。

マスタに存在しない場合のフォールバック（暫定名称）

'未一致なら「コードそのまま」や「暫定名」をつける例
Function ResolveName(ByVal code As String, ByVal dict As Object) As String
    If dict.Exists(code) Then
        ResolveName = dict(code)(0)  '名称
    Else
        ResolveName = "[暫定]" & code
    End If
End Function
VB
  • ポイント:
    • 運用継続重視: 解析や可視化を止めないための暫定措置。

ピボット前処理：マスタ結合→ピボット自動作成

Sub JoinThenPivot()
    '1) マスタ結合（辞書版を呼ぶ）で名称・カテゴリ列を付与
    Call JoinMaster_WithDictionary

    '2) ピボットを作成（カテゴリ×月×金額合計）
    Dim src As Range: Set src = Worksheets("明細").Range("A1").CurrentRegion
    Dim outWs As Worksheet
    On Error Resume Next
    Set outWs = Worksheets("ピボット")
    If outWs Is Nothing Then Set outWs = Worksheets.Add: outWs.Name = "ピボット"
    On Error GoTo 0

    Dim pc As PivotCache, pt As PivotTable
    Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, src)
    Set pt = pc.CreatePivotTable(outWs.Range("A3"), "統合ピボット")

    With pt
        .PivotFields("カテゴリ").Orientation = xlRowField
        .PivotFields("日付").Orientation = xlColumnField
        .PivotFields("日付").NumberFormat = "yyyy-mm"
        With .PivotFields("金額")
            .Orientation = xlDataField
            .Function = xlSum
            .NumberFormat = "#,##0"
        End With
    End With
End Sub
VB
  • ポイント:
    • 「結合→集計」の定型化: ボタンひとつで最新の統合ピボットが生成。

大量データの安全・高速ラップ

Sub SafeWrapStart()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Sub SafeWrapEnd()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 処理前後で挟むだけで高速化。 途中エラー時も復帰が確実。

よくある落とし穴と対策

  • ラベル揺れ（全角/半角・前後空白）で未一致が多発
    • 対策: 参照時に Trim、必要なら StrConv(vbNarrow) で半角統一、UCase/LCaseで大小文字をそろえる。
  • VLOOKUPの列番号ズレで誤参照
    • 対策: INDEX/MATCHに切り替える、または辞書で明示的に列をマッピング。
  • 未登録を見落として集計が偏る
    • 対策: 未一致を「未登録」バケットに集め、監査リストを定期出力。
  • セル往復で遅い
    • 対策: 範囲→配列→辞書→一括書き戻しにする。式を使う場合は投入後に値化。
  • 列順変更で壊れる
    • 対策: CurrentRegion＋見出し名運用、INDEX/MATCHや辞書に切り替え。

例題で練習

'例1：辞書で名称・カテゴリを付与して明細に書き戻す
Sub Example_JoinDict()
    Call JoinMaster_WithDictionary
End Sub

'例2：VLOOKUPで手早く付与して値化
Sub Example_JoinVLookup()
    Call JoinMaster_WithVLookup
End Sub

'例3：マスタのカテゴリを用いてグループ集計（未登録含む）
Sub Example_AggByCategory()
    Call Aggregate_ByMasterCategory
End Sub

'例4：結合後にピボットを自動作成
Sub Example_JoinThenPivot()
    Call JoinThenPivot
End Sub

'例5：未登録コードの監査リストを作成
Sub Example_ListUnmatched()
    Call List_UnmatchedKeys
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました