Excel VBA 逆引き集 | 単一キーJOIN

Excel VBA
スポンサーリンク

単一キーJOIN

「コード（キー）で明細にマスタ情報を付けたい」「2つの集約表をキーで横に突き合わせたい」——単一キーJOINの定番テンプレを、初心者向けにかみ砕いてまとめました。最短はVLOOKUP、堅牢・高速は配列＋辞書、列順が変わるなら見出し名で安全に参照します。

使い分けの指針

  • 最短・少量: VLOOKUPを式投入→値化（簡単で速い導入）
  • 列増減に強い: INDEX/MATCH（列番号ズレ問題を回避）
  • 大量・高速: 配列＋辞書でJOIN（10万行規模でも実用速度）
  • 横結合（左結合・フル結合）: 辞書でキー→レコードを作り、基準表へ付与
  • 見出し名で安全: 列順変更や一部欠損に強い

最短：VLOOKUPで単一キーJOIN（式→値化）

Sub Join_ByVLookup()
    '明細: A=コード, B=日付, C=金額
    'マスタ: A=コード, B=名称, C=カテゴリ
    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列
    wsD.Range("D1:E1").Value = Array("名称", "カテゴリ")
    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
End Sub
VB
  • ポイント
    • 値化して式を撤去すれば、再計算負荷や参照ズレを回避。
    • 列順が変わる可能性があるなら、次のINDEX/MATCHへ。

列増減に強い：INDEX/MATCHでJOIN（列番号不要）

Sub Join_ByIndexMatch()
    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")

    wsD.Range("D1:E1").Value = Array("名称", "カテゴリ")
    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
End Sub
VB
  • ポイント
    • 列の入れ替えや追加があっても安全。
    • 値化で軽く・安定運用。

爆速・堅牢：配列＋辞書でJOIN（単一キー）

Sub Join_ByDictionary()
    '明細: A=コード, B=日付, C=金額
    'マスタ: A=コード, B=名称, C=カテゴリ
    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 dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vm, 1)
        key = UCase$(Trim$(CStr(vm(i, 1))))
        If Len(key) > 0 Then dict(key) = Array(CStr(vm(i, 2)), CStr(vm(i, 3))) '名称,カテゴリ
    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
        key = UCase$(Trim$(CStr(vd(r, 1))))
        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
  • ポイント
    • キー正規化（Trim/UCase）で表記揺れを吸収。
    • セル往復ゼロで高速。未登録は「#N/A」で見える化。

左結合・フル結合の横統合（単一キー）

左結合（基準表に他表指標を横付け）

Sub Merge_LeftJoin()
    '基準: Sheet("基準") A=コード, B=名称, C=合計
    '追加: Sheet("他")   A=コード, B=他合計
    '出力: 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("コード", "名称", "合計", "他合計")

    '追加表辞書（コード→他合計）
    Dim vo As Variant: vo = wsO.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(vo, 1)
        key = UCase$(Trim$(CStr(vo(i, 1))))
        dict(key) = Val(vo(i, 2))
    Next

    '基準を出力しながら横付け
    Dim vb As Variant: vb = wsB.Range("A1").CurrentRegion.Value
    Dim rOut As Long: rOut = 2
    For i = 2 To UBound(vb, 1)
        key = UCase$(Trim$(CStr(vb(i, 1))))
        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(key), dict(key), 0)
        rOut = rOut + 1
    Next
    wsOut.Columns.AutoFit
End Sub
VB

フル結合（両方にあるキーは統合、片側のみは0/空欄で補完）

Sub Merge_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:D1").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 i As Long, key As String
    For i = 2 To UBound(vb, 1)
        key = UCase$(Trim$(CStr(vb(i, 1))))
        base(key) = Array(CStr(vb(i, 2)), Val(vb(i, 3)))
    Next

    '他辞書（コード→他合計）
    Dim other As Object: Set other = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vo, 1)
        key = UCase$(Trim$(CStr(vo(i, 1))))
        other(key) = Val(vo(i, 2))
    Next

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

    Dim rOut As Long: rOut = 2
    Dim k As Variant
    For Each k In all.Keys
        wsOut.Cells(rOut, 1).Value = k
        wsOut.Cells(rOut, 2).Value = IIf(base.Exists(k), base(k)(0), "")
        wsOut.Cells(rOut, 3).Value = IIf(base.Exists(k), base(k)(1), 0)
        wsOut.Cells(rOut, 4).Value = IIf(other.Exists(k), other(k), 0)
        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 Join_ByHeaderNames()
    '見出し名で列を取得して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 cKeyD As Long: cKeyD = FindHeader(rgD.Rows(1), "コード")
    Dim cKeyM As Long: cKeyM = FindHeader(rgM.Rows(1), "コード")
    Dim cNameM As Long: cNameM = FindHeader(rgM.Rows(1), "名称")
    Dim cCatM As Long: cCatM = FindHeader(rgM.Rows(1), "カテゴリ")
    If cKeyD * cKeyM * cNameM * cCatM = 0 Then MsgBox "見出しが不足しています": Exit Sub

    Dim vd As Variant: vd = rgD.Value
    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 = UCase$(Trim$(CStr(vm(i, cKeyM))))
        dict(key) = Array(CStr(vm(i, cNameM)), CStr(vm(i, cCatM)))
    Next

    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
        key = UCase$(Trim$(CStr(vd(r, cKeyD))))
        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
  • ポイント
    • 列名が変わっても、Findで動的に列番号取得。
    • 欠損列はフラグ付けで監査しやすく。

よくある落とし穴と対策

  • キーの表記揺れでJOIN失敗
    • 対策: Trim/UCase、必要なら半角化や不要記号の置換で正規化。
  • 数値が文字列で計算ずれ
    • 対策: 付与時に Val で数値化、または元データを値化して型を揃える。
  • 列順変更・列追加でコードが壊れる
    • 対策: 見出し名で列特定（FindHeader）、INDEX/MATCH採用。
  • 大規模で遅い
    • 対策: 範囲→配列→辞書→一括書戻し。前後で ScreenUpdating/Calculation/Events を停止→復帰。

例題で練習

'例1：VLOOKUPで単一キーJOIN（式→値化）
Sub Example_VLookup()
    Join_ByVLookup
End Sub

'例2：INDEX/MATCHで列増減に強いJOIN
Sub Example_IndexMatch()
    Join_ByIndexMatch
End Sub

'例3：配列＋辞書で高速JOIN
Sub Example_DictJoin()
    Join_ByDictionary
End Sub

'例4：基準表に他指標を左結合
Sub Example_LeftJoin()
    Merge_LeftJoin
End Sub

'例5：フル結合で両テーブルを完全統合
Sub Example_FullJoin()
    Merge_FullJoin
End Sub

'例6：見出し名で列特定して安全JOIN
Sub Example_ByHeaders()
    Join_ByHeaderNames
End Sub
VB

スポンサーリンク
タイトルとURLをコピーしました