Excel VBA 逆引き集 | マスタが複数シート

Excel VBA
スポンサーリンク

マスタが複数シート

「コードマスタが部署ごとに別シート」「商品マスタが複数シートに散在」——そんな現場で、壊れない統合・JOINのテンプレをまとめました。ポイントは「見出し名で安全に読み込み」「辞書に統合」「優先ルールで重複を解決」「明細に一括JOIN」です。

使い方の全体像

  • 複数マスタを安全に読み込む: 見出し名で列位置を取る（列順変更に強い）
  • 辞書に統合する: キーを正規化して「キー→レコード」を構築
  • 重複キーの解決: 先勝ち／後勝ち／非空優先などルールを適用
  • 明細にJOIN: 統合辞書から明細に付与（高速）
  • 監査を可視化: 未一致や重複の一覧を作ってチェック

複数シートのマスタを読み込み→統合辞書を作る（基本）

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

'複数シートのマスタを辞書へ統合
'keyName: キー見出し（例："コード"）
'fieldNames: 付与したい項目見出し（例：Array("名称","カテゴリ")）
'priority: "FirstWins"（先勝ち） / "LastWins"（後勝ち） / "NonEmptyWins"（非空優先）
Public Function BuildMasterDict_FromSheets(sheetNames As Variant, _
                                           keyName As String, _
                                           fieldNames As Variant, _
                                           Optional priority As String = "LastWins") As Object
    Dim master As Object: Set master = CreateObject("Scripting.Dictionary")
    Dim dupLog As Object: Set dupLog = CreateObject("Scripting.Dictionary") '重複監査用
    
    Dim s As Variant
    For Each s In sheetNames
        Dim ws As Worksheet: Set ws = Worksheets(CStr(s))
        Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
        Dim v As Variant: v = rg.Value

        '見出し→列番号
        Dim cKey As Long: cKey = FindHeader(rg.Rows(1), keyName)
        If cKey = 0 Then Err.Raise 5, , "見出し '" & keyName & "' が " & ws.Name & " にありません"
        Dim iField As Long, colMap() As Long: ReDim colMap(LBound(fieldNames) To UBound(fieldNames))
        For iField = LBound(fieldNames) To UBound(fieldNames)
            colMap(iField) = FindHeader(rg.Rows(1), CStr(fieldNames(iField)))
            If colMap(iField) = 0 Then Err.Raise 5, , "見出し '" & fieldNames(iField) & "' が " & ws.Name & " にありません"
        Next

        '行ループ
        Dim r As Long
        For r = 2 To UBound(v, 1)
            Dim key As String: key = UCase$(Trim$(CStr(v(r, cKey))))
            If Len(key) = 0 Then GoTo ContinueRow

            '行のレコードを配列で取得
            Dim rec() As Variant: ReDim rec(LBound(fieldNames) To UBound(fieldNames))
            For iField = LBound(fieldNames) To UBound(fieldNames)
                rec(iField) = v(r, colMap(iField))
            Next

            '重複解決ルール
            If master.Exists(key) Then
                dupLog(key) = True
                Select Case priority
                    Case "FirstWins"
                        '何もしない（既存を維持）
                    Case "LastWins"
                        master(key) = rec
                    Case "NonEmptyWins"
                        Dim oldRec() As Variant: oldRec = master(key)
                        For iField = LBound(fieldNames) To UBound(fieldNames)
                            If Len(oldRec(iField)) = 0 And Len(rec(iField)) > 0 Then
                                oldRec(iField) = rec(iField)
                            End If
                        Next
                        master(key) = oldRec
                End Select
            Else
                master.Add key, rec
            End If
ContinueRow:
        Next
    Next

    '監査ログをシートに出したい場合はここで作る（任意）
    If dupLog.Count > 0 Then
        Dim wsLog As Worksheet
        On Error Resume Next
        Set wsLog = Worksheets("重複監査")
        If wsLog Is Nothing Then Set wsLog = Worksheets.Add: wsLog.Name = "重複監査"
        On Error GoTo 0
        wsLog.Cells.Clear
        wsLog.Range("A1").Value = "重複キー（どのシートにも複数行存在）"
        Dim rOut As Long: rOut = 2
        Dim k As Variant
        For Each k In dupLog.Keys
            wsLog.Cells(rOut, 1).Value = k
            rOut = rOut + 1
        Next
    End If

    Set BuildMasterDict_FromSheets = master
End Function
VB
  • ポイント
    • 見出し名参照: 列順変更に強い。欠損見出しはエラーで気づく。
    • キー正規化: Trim/UCase で表記揺れ吸収。
    • 重複解決ルール: 先勝ち／後勝ち／非空優先から選べる。
    • 監査ログ: 重複キーを一覧化して後で確認できる。

統合辞書を使って明細に一括JOIN（高速）

'明細に統合マスタを付与する（左結合相当）
'detailsWs: 明細シート
'keyHeader: 明細のキー見出し
'fieldNames: マスタから付与する項目名（列名としてヘッダーに出力）
Public Sub JoinDetails_WithMasterDict(detailsWs As Worksheet, _
                                      keyHeader As String, _
                                      fieldNames As Variant, _
                                      masterDict As Object)
    Dim rg As Range: Set rg = detailsWs.Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    'キー列特定
    Dim cKey As Long: cKey = FindHeader(rg.Rows(1), keyHeader)
    If cKey = 0 Then Err.Raise 5, , "見出し '" & keyHeader & "' が " & detailsWs.Name & " にありません"

    '出力配列（明細＋付与列）
    Dim out() As Variant: ReDim out(1 To UBound(v, 1), 1 To UBound(v, 2) + UBound(fieldNames) - LBound(fieldNames) + 1)

    'ヘッダーコピー＋付与列ヘッダー
    Dim c As Long: For c = 1 To UBound(v, 2): out(1, c) = v(1, c): Next
    Dim addCount As Long: addCount = UBound(fieldNames) - LBound(fieldNames) + 1
    For c = 1 To addCount
        out(1, UBound(v, 2) + c) = fieldNames(LBound(fieldNames) + c - 1)
    Next

    '行ループ
    Dim r As Long
    For r = 2 To UBound(v, 1)
        '元データ
        For c = 1 To UBound(v, 2): out(r, c) = v(r, c): Next
        'キー→マスタ辞書
        Dim key As String: key = UCase$(Trim$(CStr(v(r, cKey))))
        If masterDict.Exists(key) Then
            Dim rec() As Variant: rec = masterDict(key)
            For c = 1 To addCount
                out(r, UBound(v, 2) + c) = rec(LBound(fieldNames) + c - 1)
            Next
        Else
            '未一致の可視化（空欄や#N/Aなど運用に合わせて）
            For c = 1 To addCount
                out(r, UBound(v, 2) + c) = "#N/A"
            Next
        End If
    Next

    '書き戻し
    rg.Resize(UBound(out, 1), UBound(out, 2)).Value = out
End Sub
VB
  • ポイント
    • 高速: 範囲→配列→辞書→一括貼付でセル往復ゼロ。
    • 未一致可視化: 「#N/A」等を入れて監査しやすく。

統合マスタを表として出力（後工程用）

'統合辞書をシートに出力
Public Sub DumpMasterDict(masterDict As Object, fieldNames As Variant, Optional outSheetName As String = "統合マスタ")
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(outSheetName)
    If ws Is Nothing Then Set ws = Worksheets.Add: ws.Name = outSheetName
    On Error GoTo 0

    ws.Cells.Clear

    'ヘッダー: キー＋項目
    ws.Cells(1, 1).Value = "キー"
    Dim i As Long
    For i = LBound(fieldNames) To UBound(fieldNames)
        ws.Cells(1, i - LBound(fieldNames) + 2).Value = fieldNames(i)
    Next

    '行データ
    Dim k As Variant, rOut As Long: rOut = 2
    For Each k In masterDict.Keys
        ws.Cells(rOut, 1).Value = k
        Dim rec() As Variant: rec = masterDict(k)
        For i = LBound(fieldNames) To UBound(fieldNames)
            ws.Cells(rOut, i - LBound(fieldNames) + 2).Value = rec(i)
        Next
        rOut = rOut + 1
    Next

    ws.Columns.AutoFit
End Sub
VB
  • ポイント
    • 見える化: 統合後のマスタを表にして、ピボットや手作業にも回せる。
    • キー列: 監査・検索・重複確認がしやすい。

よくある落とし穴と対策

  • 見出しがシートごとに微妙に違う
    • 対策: 見出し名で列特定。見出しの別名（例：コード/商品コード）に対応するには、事前に置換表を当てるか、複数候補で探す。
  • キーの表記揺れでJOIN漏れ
    • 対策: 正規化: Trim/UCase、必要なら半角化（StrConv(..., vbNarrow)）や不要記号の Replace。
  • 重複キーのどちらを採用するか決まっていない
    • 対策: 優先ルール: 先勝ち／後勝ち／非空優先を選ぶ。監査用シートに重複キーを出す。
  • 数値が文字列で計算ズレ
    • 対策: 数値化: Val で安全に数値へ。必要なら .Value = .Value で値化。
  • 大規模処理で遅い
    • 対策: 配列・辞書・一括貼付に徹する。前後で Application.ScreenUpdating・Calculation・EnableEvents を停止→復帰。

例題で練習

'例1：3つのマスタシートを統合して辞書作成（後勝ちルール）
Sub Example_BuildMaster()
    Dim dict As Object
    dict = BuildMasterDict_FromSheets(Array("商品M1", "商品M2", "商品M3"), _
                                      "コード", Array("名称", "カテゴリ"), "LastWins")
    DumpMasterDict dict, Array("名称", "カテゴリ"), "統合マスタ"
End Sub

'例2：統合マスタを使って明細にJOIN
Sub Example_JoinDetails()
    Dim dict As Object
    dict = BuildMasterDict_FromSheets(Array("商品M1", "商品M2"), _
                                      "コード", Array("名称", "カテゴリ"), "NonEmptyWins")
    Call JoinDetails_WithMasterDict(Worksheets("明細"), "コード", Array("名称", "カテゴリ"), dict)
End Sub

'例3：重複キー監査だけ先に確認（先勝ちで固定）
Sub Example_AuditDup()
    Dim dict As Object
    dict = BuildMasterDict_FromSheets(Array("商品M1", "商品M2", "商品M3"), _
                                      "コード", Array("名称"), "FirstWins")
    '重複は「重複監査」シートに出力済み
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました