Excel VBA 逆引き集 | A/Bマスタの突合

Excel VBA
スポンサーリンク

A/Bマスタの突合

「AマスタとBマスタを突き合わせて、一致・不一致・差分（名称や属性の違い）を洗い出したい」——初心者でも壊れず、現場でそのまま使えるテンプレをまとめました。肝は「キーの正規化」「見出し名で列特定」「配列＋辞書で高速」「未一致・差分を“見える化”」です。

突合の設計指針

  • キーの決定: コードなどの主キーを必ず一つに定め、複数キーは安全な区切りで連結（例：”コード|年月”）。
  • 正規化の徹底: キーは Trim/UCase（必要なら半角化）で表記揺れを吸収。
  • 列順変動に耐える: 見出し名で列位置を取得して参照（ハードコードしない）。
  • 突合の出力粒度: 1) 完全一致、2) 片側のみ、3) 値が異なる（項目別）に分けて可視化。
  • 速度最適化: 範囲→配列→辞書→一括貼付。セルを行き来しない。

下準備：見出し特定と新シートユーティリティ

Option Explicit

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

Public 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
VB
  • ポイント
    • FindHeader: 見出し名で列位置を取得して壊れにくく。
    • EnsureSheet: 何度実行しても安全に再利用/作成。

単一キーの突合：一致・未登録・差分の3分類

AマスタとBマスタを「コード」キーで突合し、3分類を別シートに出力します。

Sub ReconcileMasters_Simple()
    'A: Sheet("Aマスタ") A=コード, B=名称, C=カテゴリ
    'B: Sheet("Bマスタ") A=コード, B=名称, C=カテゴリ

    Dim wsA As Worksheet: Set wsA = Worksheets("Aマスタ")
    Dim wsB As Worksheet: Set wsB = Worksheets("Bマスタ")
    Dim rgA As Range: Set rgA = wsA.Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = wsB.Range("A1").CurrentRegion
    Dim vA As Variant: vA = rgA.Value
    Dim vB As Variant: vB = rgB.Value

    '見出し列特定
    Dim cKeyA As Long: cKeyA = FindHeader(rgA.Rows(1), "コード")
    Dim cNameA As Long: cNameA = FindHeader(rgA.Rows(1), "名称")
    Dim cCatA  As Long: cCatA  = FindHeader(rgA.Rows(1), "カテゴリ")
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    Dim cNameB As Long: cNameB = FindHeader(rgB.Rows(1), "名称")
    Dim cCatB  As Long: cCatB  = FindHeader(rgB.Rows(1), "カテゴリ")
    If cKeyA*cNameA*cCatA*cKeyB*cNameB*cCatB = 0 Then MsgBox "見出し不足": Exit Sub

    'B辞書（キー→(名称,カテゴリ)）
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vB, 1)
        key = UCase$(Trim$(CStr(vB(i, cKeyB))))
        If Len(key) > 0 Then dictB(key) = Array(CStr(vB(i, cNameB)), CStr(vB(i, cCatB)))
    Next

    '出力シート
    Dim wsOK As Worksheet: Set wsOK = EnsureSheet("一致", True)
    Dim wsMissA As Worksheet: Set wsMissA = EnsureSheet("Bに未登録", True)
    Dim wsMissB As Worksheet: Set wsMissB = EnsureSheet("Aに未登録", True)
    Dim wsDiff As Worksheet: Set wsDiff = EnsureSheet("差分", True)

    wsOK.Range("A1:D1").Value = Array("コード", "名称(A)", "名称(B)", "カテゴリ一致")
    wsMissA.Range("A1:C1").Value = Array("コード", "名称(A)", "カテゴリ(A)")
    wsMissB.Range("A1:C1").Value = Array("コード", "名称(B)", "カテゴリ(B)")
    wsDiff.Range("A1:E1").Value = Array("コード", "項目", "A値", "B値", "備考")

    'Aを走査：一致/差分/未登録(B)
    Dim rOK As Long: rOK = 2
    Dim rDiff As Long: rDiff = 2
    Dim rMissA As Long: rMissA = 2

    For i = 2 To UBound(vA, 1)
        key = UCase$(Trim$(CStr(vA(i, cKeyA))))
        If Len(key) = 0 Then GoTo nextA

        Dim aName As String: aName = CStr(vA(i, cNameA))
        Dim aCat  As String: aCat  = CStr(vA(i, cCatA))

        If dictB.Exists(key) Then
            Dim bName As String: bName = dictB(key)(0)
            Dim bCat  As String: bCat  = dictB(key)(1)
            If aName = bName And aCat = bCat Then
                wsOK.Cells(rOK, 1).Value = key
                wsOK.Cells(rOK, 2).Value = aName
                wsOK.Cells(rOK, 3).Value = bName
                wsOK.Cells(rOK, 4).Value = IIf(aCat = bCat, "一致", "不一致") '名称一致ならカテゴリも見ておく
                rOK = rOK + 1
            Else
                If aName <> bName Then
                    wsDiff.Cells(rDiff, 1).Value = key
                    wsDiff.Cells(rDiff, 2).Value = "名称"
                    wsDiff.Cells(rDiff, 3).Value = aName
                    wsDiff.Cells(rDiff, 4).Value = bName
                    wsDiff.Cells(rDiff, 5).Value = ""
                    rDiff = rDiff + 1
                End If
                If aCat <> bCat Then
                    wsDiff.Cells(rDiff, 1).Value = key
                    wsDiff.Cells(rDiff, 2).Value = "カテゴリ"
                    wsDiff.Cells(rDiff, 3).Value = aCat
                    wsDiff.Cells(rDiff, 4).Value = bCat
                    wsDiff.Cells(rDiff, 5).Value = ""
                    rDiff = rDiff + 1
                End If
            End If
        Else
            wsMissA.Cells(rMissA, 1).Value = key
            wsMissA.Cells(rMissA, 2).Value = aName
            wsMissA.Cells(rMissA, 3).Value = aCat
            rMissA = rMissA + 1
        End If
nextA:
    Next

    'Bのみ（Aに未登録）を出力
    Dim presentA As Object: Set presentA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        key = UCase$(Trim$(CStr(vA(i, cKeyA))))
        If Len(key) > 0 Then presentA(key) = True
    Next

    Dim rMissB As Long: rMissB = 2
    Dim j As Long
    For j = 2 To UBound(vB, 1)
        key = UCase$(Trim$(CStr(vB(j, cKeyB))))
        If Len(key) > 0 And Not presentA.Exists(key) Then
            wsMissB.Cells(rMissB, 1).Value = key
            wsMissB.Cells(rMissB, 2).Value = CStr(vB(j, cNameB))
            wsMissB.Cells(rMissB, 3).Value = CStr(vB(j, cCatB))
            rMissB = rMissB + 1
        End If
    Next

    wsOK.Columns.AutoFit: wsDiff.Columns.AutoFit
    wsMissA.Columns.AutoFit: wsMissB.Columns.AutoFit
End Sub
VB
  • ポイント
    • 3分類出力: 一致・差分・片側未登録を一目で把握。
    • 項目別差分: 1差分＝1行にすると修正方針が立てやすい。

比較項目を柔軟に増減（配列指定）

「名称・カテゴリ・単価・ステータスなど、比較項目が増える」ケースに対応します。

Sub ReconcileMasters_Flexible()
    'A/Bどちらも「コード」キー。比較項目を配列で指定
    Dim vA As Variant: vA = Worksheets("Aマスタ").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("Bマスタ").Range("A1").CurrentRegion.Value

    Dim cKeyA As Long: cKeyA = FindHeader(Worksheets("Aマスタ").Range("A1").CurrentRegion.Rows(1), "コード")
    Dim cKeyB As Long: cKeyB = FindHeader(Worksheets("Bマスタ").Range("A1").CurrentRegion.Rows(1), "コード")
    If cKeyA * cKeyB = 0 Then MsgBox "キー見出し不足": Exit Sub

    '比較したい項目（見出し名）
    Dim fields As Variant: fields = Array("名称", "カテゴリ", "単価", "ステータス")

    'A/B項目→列番号
    Dim mapA() As Long: ReDim mapA(LBound(fields) To UBound(fields))
    Dim mapB() As Long: ReDim mapB(LBound(fields) To UBound(fields))
    Dim i As Long
    For i = LBound(fields) To UBound(fields)
        mapA(i) = FindHeader(Worksheets("Aマスタ").Range("A1").CurrentRegion.Rows(1), CStr(fields(i)))
        mapB(i) = FindHeader(Worksheets("Bマスタ").Range("A1").CurrentRegion.Rows(1), CStr(fields(i)))
        If mapA(i) = 0 Or mapB(i) = 0 Then MsgBox "見出し不足：" & fields(i): Exit Sub
    Next

    'B辞書（キー→行番号）
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim k As String, r As Long
    For r = 2 To UBound(vB, 1)
        k = UCase$(Trim$(CStr(vB(r, cKeyB))))
        If Len(k) > 0 Then dictB(k) = r
    Next

    '出力
    Dim wsDiff As Worksheet: Set wsDiff = EnsureSheet("差分_柔軟", True)
    wsDiff.Range("A1:D1").Value = Array("コード", "項目", "A値", "B値")
    Dim rOut As Long: rOut = 2

    'Aを走査（差分のみ出す）
    For r = 2 To UBound(vA, 1)
        k = UCase$(Trim$(CStr(vA(r, cKeyA))))
        If Len(k) = 0 Then GoTo contA
        If dictB.Exists(k) Then
            Dim rb As Long: rb = dictB(k)
            For i = LBound(fields) To UBound(fields)
                Dim va As Variant: va = vA(r, mapA(i))
                Dim vb As Variant: vb = vB(rb, mapB(i))
                Dim isDiff As Boolean
                If fields(i) Like "*単価*" Or fields(i) Like "*金額*" Then
                    isDiff = (CDbl(Val(va)) <> CDbl(Val(vb)))
                Else
                    isDiff = (CStr(va) <> CStr(vb))
                End If
                If isDiff Then
                    wsDiff.Cells(rOut, 1).Value = k
                    wsDiff.Cells(rOut, 2).Value = fields(i)
                    wsDiff.Cells(rOut, 3).Value = va
                    wsDiff.Cells(rOut, 4).Value = vb
                    rOut = rOut + 1
                End If
            Next
        End If
contA:
    Next

    wsDiff.Columns.AutoFit
End Sub
VB
  • ポイント
    • 項目配列: 比較対象を簡単に増減できる。
    • 数値項目は数値比較: 文字列化による比較ズレを防ぐ。

複数キーの突合（例：コード×年月）

部署や年月などを含めた複合キーで突合するテンプレです。

Sub ReconcileMasters_MultiKey()
    'A: A=コード, B=年月, C=名称
    'B: A=コード, B=年月, C=名称B
    Dim rgA As Range: Set rgA = Worksheets("Aマスタ").Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = Worksheets("Bマスタ").Range("A1").CurrentRegion
    Dim vA As Variant: vA = rgA.Value
    Dim vB As Variant: vB = rgB.Value

    '見出し
    Dim cCodeA As Long: cCodeA = FindHeader(rgA.Rows(1), "コード")
    Dim cYmA   As Long: cYmA   = FindHeader(rgA.Rows(1), "年月")
    Dim cNameA As Long: cNameA = FindHeader(rgA.Rows(1), "名称")
    Dim cCodeB As Long: cCodeB = FindHeader(rgB.Rows(1), "コード")
    Dim cYmB   As Long: cYmB   = FindHeader(rgB.Rows(1), "年月")
    Dim cNameB As Long: cNameB = FindHeader(rgB.Rows(1), "名称B")
    If cCodeA*cYmA*cNameA*cCodeB*cYmB*cNameB = 0 Then MsgBox "見出し不足": Exit Sub

    'B辞書（key="コード|yyyy-mm" → 名称B）
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vB, 1)
        Dim ymB As String
        ymB = IIf(IsDate(vB(i, cYmB)), Format$(CDate(vB(i, cYmB)), "yyyy-mm"), CStr(vB(i, cYmB)))
        key = UCase$(Trim$(CStr(vB(i, cCodeB)))) & "|" & UCase$(Trim$(ymB))
        dictB(key) = CStr(vB(i, cNameB))
    Next

    '出力
    Dim wsDiff As Worksheet: Set wsDiff = EnsureSheet("差分_複数キー", True)
    wsDiff.Range("A1:D1").Value = Array("コード", "年月", "名称(A)", "名称(B)")
    Dim rOut As Long: rOut = 2

    For i = 2 To UBound(vA, 1)
        Dim ymA As String
        ymA = IIf(IsDate(vA(i, cYmA)), Format$(CDate(vA(i, cYmA)), "yyyy-mm"), CStr(vA(i, cYmA)))
        key = UCase$(Trim$(CStr(vA(i, cCodeA)))) & "|" & UCase$(Trim$(ymA))
        Dim aName As String: aName = CStr(vA(i, cNameA))
        Dim bName As String: bName = IIf(dictB.Exists(key), dictB(key), "")
        If bName = "" Or aName <> bName Then
            wsDiff.Cells(rOut, 1).Value = vA(i, cCodeA)
            wsDiff.Cells(rOut, 2).Value = ymA
            wsDiff.Cells(rOut, 3).Value = aName
            wsDiff.Cells(rOut, 4).Value = bName
            rOut = rOut + 1
        End If
    Next

    wsDiff.Columns.AutoFit
End Sub
VB
  • ポイント
    • 年月統一: Date型なら Format$("yyyy-mm") で表記統一。
    • 安全な区切り: "|" のようなデータに出てこない記号を使う。

和集合・共通集合で全体像を可視化（完全・内部）

「両側にあるキー（内部）」「片側だけのキー（差分）」を一覧化します。

Sub ReconcileMasters_Sets()
    Dim vA As Variant: vA = Worksheets("Aマスタ").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("Bマスタ").Range("A1").CurrentRegion.Value
    Dim cKeyA As Long: cKeyA = FindHeader(Worksheets("Aマスタ").Range("A1").CurrentRegion.Rows(1), "コード")
    Dim cKeyB As Long: cKeyB = FindHeader(Worksheets("Bマスタ").Range("A1").CurrentRegion.Rows(1), "コード")
    If cKeyA * cKeyB = 0 Then MsgBox "見出し不足": Exit Sub

    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    Dim setB As Object: Set setB = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vA, 1)
        k = UCase$(Trim$(CStr(vA(i, cKeyA))))
        If Len(k) > 0 Then setA(k) = True
    Next
    For i = 2 To UBound(vB, 1)
        k = UCase$(Trim$(CStr(vB(i, cKeyB))))
        If Len(k) > 0 Then setB(k) = True
    Next

    Dim ws As Worksheet: Set ws = EnsureSheet("集合比較", True)
    ws.Range("A1:C1").Value = Array("キー", "分類", "備考")

    Dim rOut As Long: rOut = 2
    Dim all As Object: Set all = CreateObject("Scripting.Dictionary")
    For Each k In setA.Keys: all(k) = True: Next
    For Each k In setB.Keys: all(k) = True: Next

    Dim key As Variant
    For Each key In all.Keys
        ws.Cells(rOut, 1).Value = key
        If setA.Exists(key) And setB.Exists(key) Then
            ws.Cells(rOut, 2).Value = "共通（内部）"
        ElseIf setA.Exists(key) Then
            ws.Cells(rOut, 2).Value = "Aのみ"
        Else
            ws.Cells(rOut, 2).Value = "Bのみ"
        End If
        rOut = rOut + 1
    Next

    ws.Columns.AutoFit
End Sub
VB
  • ポイント
    • 集合の発想: 突合の全体像を「共通/片側のみ」で整理。
    • 監査の起点: まず集合で全体把握→差分詳細へ。

監査の見える化（重複・未一致・件数）

「B辞書化時に重複発生」「突合の未一致キー」を同時に出力して監査強化します。

Sub ReconcileMasters_WithAudit()
    Dim vA As Variant: vA = Worksheets("Aマスタ").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("Bマスタ").Range("A1").CurrentRegion.Value
    Dim cKeyA As Long: cKeyA = FindHeader(Worksheets("Aマスタ").Range("A1").CurrentRegion.Rows(1), "コード")
    Dim cKeyB As Long: cKeyB = FindHeader(Worksheets("Bマスタ").Range("A1").CurrentRegion.Rows(1), "コード")
    Dim cNameA As Long: cNameA = FindHeader(Worksheets("Aマスタ").Range("A1").CurrentRegion.Rows(1), "名称")
    Dim cNameB As Long: cNameB = FindHeader(Worksheets("Bマスタ").Range("A1").CurrentRegion.Rows(1), "名称")
    If cKeyA*cKeyB*cNameA*cNameB = 0 Then MsgBox "見出し不足": Exit Sub

    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim dupB As Object: Set dupB = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vB, 1)
        key = UCase$(Trim$(CStr(vB(i, cKeyB))))
        If dictB.Exists(key) Then
            dupB(key) = True
        Else
            dictB(key) = CStr(vB(i, cNameB))
        End If
    Next

    Dim miss As Object: Set miss = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        key = UCase$(Trim$(CStr(vA(i, cKeyA))))
        If Len(key) > 0 And Not dictB.Exists(key) Then miss(key) = True
    Next

    Dim wsLog As Worksheet: Set wsLog = EnsureSheet("突合監査", True)
    wsLog.Range("A1:B1").Value = Array("AにあってBにないキー", "B側重複キー")
    Dim r1 As Long: r1 = 2
    Dim x As Variant
    For Each x In miss.Keys: wsLog.Cells(r1, 1).Value = x: r1 = r1 + 1: Next
    Dim r2 As Long: r2 = 2
    For Each x In dupB.Keys: wsLog.Cells(r2, 2).Value = x: r2 = r2 + 1: Next
    wsLog.Columns.AutoFit
End Sub
VB
  • ポイント
    • 重複の即可視化: マスタ側の品質問題を早期に把握。
    • 未一致一覧: 修正・登録漏れの起票に直結。

よくある落とし穴と対策

  • キー表記揺れで一致判定が崩れる
    • 対策: 正規化: Trim/UCase、必要なら半角化（StrConv）や記号除去（Replace）。
  • 日付・年月の型が混在
    • 対策: 統一表記: Date型は Format$("yyyy-mm") へ変換して比較。
  • 数値を文字列で比較して誤判定
    • 対策: 数値化: Val→CDbl で比較。書式は出力時に整える。
  • 列順変更で壊れる
    • 対策: 見出し名参照: FindHeaderで列位置取得。ハードコード禁止。
  • 大規模で遅い
    • 対策: 配列＋辞書＋一括貼付。前後で ScreenUpdating=False と計算停止で安定。

例題で練習

'例1：単一キーの3分類突合
Sub Example_ReconcileSimple()
    ReconcileMasters_Simple
End Sub

'例2：比較項目を柔軟指定して差分一覧
Sub Example_ReconcileFlexible()
    ReconcileMasters_Flexible
End Sub

'例3：複数キー（コード×年月）の突合
Sub Example_ReconcileMultiKey()
    ReconcileMasters_MultiKey
End Sub

'例4：集合比較で全体像を可視化
Sub Example_ReconcileSets()
    ReconcileMasters_Sets
End Sub

'例5：監査ログ（未一致・重複）を出力
Sub Example_ReconcileAudit()
    ReconcileMasters_WithAudit
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました