Excel VBA 逆引き集 | 複数キーJOIN

Excel VBA
スポンサーリンク

複数キーJOIN

「部署×年月」「コード×枝番」など、2つ以上のキーで明細にマスタ情報を付けたり、集約表同士を横に突き合わせたいときのテンプレをまとめました。初心者でも壊れないやり方を、関数・配列＋辞書・見出し名対応で用意しています。

使い分けの指針

  • 最短・少量: ヘルパー列でキー連結→VLOOKUP（式投入→値化）
  • 列増減に強い: ヘルパー列＋INDEX/MATCH（列番号不要で堅牢）
  • 大量・高速: 配列＋辞書で「複合キー」JOIN（10万行規模でも実用）
  • 横統合（左結合・フル結合）: 辞書でキー→値を作り、基準表に横付け
  • 列順が変わる現場: 見出し名から列特定して安全に参照

最短：ヘルパー列でキー連結→VLOOKUP（式→値化）

Sub JoinMultiKey_VLookup()
    '明細: A=部署, B=年月, C=金額
    'マスタ: A=部署, B=年月, C=名称, D=カテゴリ
    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 lastM As Long: lastM = wsM.Cells(wsM.Rows.Count, "A").End(xlUp).Row

    wsD.Range("E1").Value = "key"
    wsD.Range("E2:E" & lastD).FormulaR1C1 = "=RC1&""|""&RC2"
    wsD.Range("E2:E" & lastD).Value = wsD.Range("E2:E" & lastD).Value

    wsM.Range("E1").Value = "key"
    wsM.Range("E2:E" & lastM).FormulaR1C1 = "=RC1&""|""&RC2"
    wsM.Range("E2:E" & lastM).Value = wsM.Range("E2:E" & lastM).Value

    'VLOOKUPで名称・カテゴリを付与（値化）
    Dim tblM As Range: Set tblM = wsM.Range("E1").CurrentRegion 'E=key起点
    wsD.Range("F1:G1").Value = Array("名称", "カテゴリ")

    With wsD.Range("F2:F" & lastD)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC5," & tblM.Address(True, True, xlA1, True) & ",3,FALSE),""#N/A"")"
        .Value = .Value
    End With
    With wsD.Range("G2:G" & lastD)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC5," & tblM.Address(True, True, xlA1, True) & ",4,FALSE),""#N/A"")"
        .Value = .Value
    End With
End Sub
VB
  • ポイント
    • ヘルパー列: 複合キーは区切り文字（例：”|”）で連結して1列に。
    • 値化必須: 式は処理後に値化して軽く・安全にする。

堅牢：ヘルパー列＋INDEX/MATCH（列番号不要）

Sub JoinMultiKey_IndexMatch()
    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 lastM As Long: lastM = wsM.Cells(wsM.Rows.Count, "A").End(xlUp).Row

    '複合キー列（E列）を両方に
    wsD.Range("E1").Value = "key"
    wsD.Range("E2:E" & lastD).FormulaR1C1 = "=RC1&""|""&RC2"
    wsD.Range("E2:E" & lastD).Value = wsD.Range("E2:E" & lastD).Value

    wsM.Range("E1").Value = "key"
    wsM.Range("E2:E" & lastM).FormulaR1C1 = "=RC1&""|""&RC2"
    wsM.Range("E2:E" & lastM).Value = wsM.Range("E2:E" & lastM).Value

    'INDEX/MATCHで付与（名称=列C, カテゴリ=列D）
    Dim rngKeyM As Range: Set rngKeyM = wsM.Range("E:E")
    Dim rngNameM As Range: Set rngNameM = wsM.Range("C:C")
    Dim rngCatM As Range: Set rngCatM = wsM.Range("D:D")

    wsD.Range("F1:G1").Value = Array("名称", "カテゴリ")
    With wsD.Range("F2:F" & lastD)
        .FormulaR1C1 = "=IFERROR(INDEX(" & rngNameM.Address(True, True, xlA1, True) & ",MATCH(RC5," & rngKeyM.Address(True, True, xlA1, True) & ",0)),""#N/A"")"
        .Value = .Value
    End With
    With wsD.Range("G2:G" & lastD)
        .FormulaR1C1 = "=IFERROR(INDEX(" & rngCatM.Address(True, True, xlA1, True) & ",MATCH(RC5," & rngKeyM.Address(True, True, xlA1, True) & ",0)),""#N/A"")"
        .Value = .Value
    End With
End Sub
VB
  • ポイント
    • 列増減に強い: 参照は列名（列範囲）に紐付ける。
    • VLOOKUPの列番号ズレ問題を回避。

爆速・堅牢：配列＋辞書で複数キーJOIN（複合キー）

Sub JoinMultiKey_Dictionary()
    '明細: A=部署, B=年月, C=金額
    'マスタ: A=部署, B=年月, C=名称, D=カテゴリ
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")

    '1) マスタ→辞書（key="部署|年月" → (名称,カテゴリ)）
    Dim vm As Variant: vm = wsM.Range("A1").CurrentRegion.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vm, 1)
        k = UCase$(Trim$(CStr(vm(i, 1)))) & "|" & UCase$(Trim$(CStr(vm(i, 2))))
        dict(k) = Array(CStr(vm(i, 3)), CStr(vm(i, 4)))
    Next

    '2) 明細→配列に読み込み、名称・カテゴリ列を追加して書き戻し
    Dim vd As Variant: vd = wsD.Range("A1").CurrentRegion.Value
    Dim out() As Variant: ReDim out(1 To UBound(vd, 1), 1 To UBound(vd, 2) + 2)

    'ヘッダー
    Dim 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) = "カテゴリ"

    '行ループ
    Dim r As Long
    For r = 2 To UBound(vd, 1)
        For c = 1 To UBound(vd, 2): out(r, c) = vd(r, c): Next
        k = UCase$(Trim$(CStr(vd(r, 1)))) & "|" & UCase$(Trim$(CStr(vd(r, 2))))
        If dict.Exists(k) Then
            out(r, UBound(vd, 2) + 1) = dict(k)(0)
            out(r, UBound(vd, 2) + 2) = dict(k)(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
  • ポイント
    • キー正規化: Trim/UCase で表記揺れを吸収。
    • セル往復ゼロ: 範囲→配列→辞書→一括書き戻しで高速。

横統合：複数キーで左結合・フル結合（基準表に他指標を横付け）

Sub MergeMultiKey_LeftJoin()
    '基準: Sheet("基準") A=部署, B=年月, C=合計
    '追加: Sheet("他指標") A=部署, B=年月, C=他合計
    '出力: Sheet("統合")
    Dim wsB As Worksheet: Set wsB = Worksheets("基準")
    Dim wsO As Worksheet: Set wsO = Worksheets("他指標")
    Dim wsOut As Worksheet
    On Error Resume Next
    Set wsOut = Worksheets("統合")
    If wsOut Is Nothing Then Set wsOut = Worksheets.Add: wsOut.Name = "統合"
    On Error GoTo 0
    wsOut.Cells.Clear
    wsOut.Range("A1:D1").Value = Array("部署", "年月", "合計", "他合計")

    '追加辞書（key="部署|年月" → 他合計）
    Dim vo As Variant: vo = wsO.Range("A1").CurrentRegion.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vo, 1)
        k = UCase$(Trim$(CStr(vo(i, 1)))) & "|" & UCase$(Trim$(CStr(vo(i, 2))))
        dict(k) = Val(vo(i, 3))
    Next

    '基準を出力しながら横付け
    Dim vb As Variant: vb = wsB.Range("A1").CurrentRegion.Value
    Dim rOut As Long: rOut = 2
    For i = 2 To UBound(vb, 1)
        k = UCase$(Trim$(CStr(vb(i, 1)))) & "|" & UCase$(Trim$(CStr(vb(i, 2))))
        wsOut.Cells(rOut, 1).Value = vb(i, 1)
        wsOut.Cells(rOut, 2).Value = vb(i, 2)
        wsOut.Cells(rOut, 3).Value = Val(vb(i, 3))
        wsOut.Cells(rOut, 4).Value = IIf(dict.Exists(k), dict(k), 0)
        rOut = rOut + 1
    Next
    wsOut.Columns.AutoFit
End Sub
VB
Sub MergeMultiKey_FullJoin()
    '基準・追加の両キーを和集合にしてフル結合
    Dim wsB As Worksheet: Set wsB = Worksheets("基準")
    Dim wsO As Worksheet: Set wsO = Worksheets("他指標")
    Dim wsOut As Worksheet
    On Error Resume Next
    Set wsOut = Worksheets("統合")
    If wsOut Is Nothing Then Set wsOut = Worksheets.Add: wsOut.Name = "統合"
    On Error GoTo 0
    wsOut.Cells.Clear
    wsOut.Range("A1:E1").Value = Array("部署", "年月", "合計", "他合計", "キー")

    Dim vb As Variant: vb = wsB.Range("A1").CurrentRegion.Value
    Dim vo As Variant: vo = wsO.Range("A1").CurrentRegion.Value

    Dim base As Object: Set base = CreateObject("Scripting.Dictionary")
    Dim other As Object: Set other = CreateObject("Scripting.Dictionary")

    Dim i As Long, k As String
    For i = 2 To UBound(vb, 1)
        k = UCase$(Trim$(CStr(vb(i, 1)))) & "|" & UCase$(Trim$(CStr(vb(i, 2))))
        base(k) = Array(CStr(vb(i, 1)), CStr(vb(i, 2)), Val(vb(i, 3)))
    Next
    For i = 2 To UBound(vo, 1)
        k = UCase$(Trim$(CStr(vo(i, 1)))) & "|" & UCase$(Trim$(CStr(vo(i, 2))))
        other(k) = Val(vo(i, 3))
    Next

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

    Dim rOut As Long: rOut = 2
    Dim key As Variant
    For Each key In all.Keys
        Dim dep As String, ym As String, sumB As Double, sumO As Double
        If base.Exists(key) Then
            dep = base(key)(0): ym = base(key)(1): sumB = base(key)(2)
        Else
            dep = Split(key, "|")(0): ym = Split(key, "|")(1): sumB = 0
        End If
        sumO = IIf(other.Exists(key), other(key), 0)

        wsOut.Cells(rOut, 1).Value = dep
        wsOut.Cells(rOut, 2).Value = ym
        wsOut.Cells(rOut, 3).Value = sumB
        wsOut.Cells(rOut, 4).Value = sumO
        wsOut.Cells(rOut, 5).Value = key
        rOut = rOut + 1
    Next
    wsOut.Columns.AutoFit
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
VB
Sub JoinMultiKey_ByHeaders()
    '見出し名で「部署」「年月」を特定して複合キーJOIN
    Dim wsD As Worksheet: Set wsD = Worksheets("明細")
    Dim wsM As Worksheet: Set wsM = Worksheets("マスタ")

    Dim rgD As Range: Set rgD = wsD.Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = wsM.Range("A1").CurrentRegion

    Dim cDepD As Long: cDepD = FindHeader(rgD.Rows(1), "部署")
    Dim cYmD  As Long: cYmD  = FindHeader(rgD.Rows(1), "年月")
    Dim cDepM As Long: cDepM = FindHeader(rgM.Rows(1), "部署")
    Dim cYmM  As Long: cYmM  = FindHeader(rgM.Rows(1), "年月")
    Dim cNameM As Long: cNameM = FindHeader(rgM.Rows(1), "名称")
    Dim cCatM  As Long: cCatM  = FindHeader(rgM.Rows(1), "カテゴリ")
    If cDepD*cYmD*cDepM*cYmM*cNameM*cCatM = 0 Then MsgBox "見出しが不足しています": Exit Sub

    Dim vm As Variant: vm = rgM.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vm, 1)
        k = UCase$(Trim$(CStr(vm(i, cDepM)))) & "|" & UCase$(Trim$(CStr(vm(i, cYmM))))
        dict(k) = Array(CStr(vm(i, cNameM)), CStr(vm(i, cCatM)))
    Next

    Dim vd As Variant: vd = rgD.Value
    Dim out() As Variant: ReDim out(1 To UBound(vd, 1), 1 To UBound(vd, 2) + 2)
    Dim 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) = "カテゴリ"

    Dim r As Long
    For r = 2 To UBound(vd, 1)
        For c = 1 To UBound(vd, 2): out(r, c) = vd(r, c): Next
        k = UCase$(Trim$(CStr(vd(r, cDepD)))) & "|" & UCase$(Trim$(CStr(vd(r, cYmD))))
        If dict.Exists(k) Then
            out(r, UBound(vd, 2) + 1) = dict(k)(0)
            out(r, UBound(vd, 2) + 2) = dict(k)(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
  • ポイント
    • 列順変動に耐性: 見出し名から動的に列番号を取得。
    • 監査しやすさ: 未一致は「#N/A」で可視化。

よくある落とし穴と対策

  • キー表記揺れでJOIN失敗
    • 対策: 正規化: Trim/UCase、必要なら半角化や不要記号の置換も。
  • 年月の型が違う（2024-01と日付型など）
    • 対策: 統一: 連結前に Format$(DateValue(日付),"yyyy-mm") で同じ表記へ。
  • 区切り文字が値と衝突
    • 対策: 安全な区切り: "|" など、実データに現れないものを採用。
  • 数値が文字列で合計ずれ
    • 対策: 数値化: Val を通す、式は .Value = .Value で値化。
  • 大規模で遅い
    • 対策: 配列処理＋安全ラップ: ScreenUpdating/Calculation/Events を停止→復帰。

例題で練習

'例1：複合キー（部署|年月）をヘルパー列で作ってVLOOKUPで付与
Sub Example_VLookupMulti()
    JoinMultiKey_VLookup
End Sub

'例2：複合キー＋INDEX/MATCH（列増減に強い）
Sub Example_IndexMatchMulti()
    JoinMultiKey_IndexMatch
End Sub

'例3：配列＋辞書で複合キーJOIN（高速）
Sub Example_DictMulti()
    JoinMultiKey_Dictionary
End Sub

'例4：基準×他指標を複数キーで左結合
Sub Example_LeftJoinMulti()
    MergeMultiKey_LeftJoin
End Sub

'例5：複数キーでフル結合して完全統合
Sub Example_FullJoinMulti()
    MergeMultiKey_FullJoin
End Sub

'例6：見出し名で列特定→複合キーJOIN（列順変更に強い）
Sub Example_ByHeadersMulti()
    JoinMultiKey_ByHeaders
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました