Excel VBA 逆引き集 | 逆引きJOIN

Excel VBA
スポンサーリンク

逆引きJOIN

やりたいJOINから選べる“逆引きテンプレ”。「明細にマスタを左結合したい」「一致する行だけ内結合」「両方のキーを全部出したい完全結合」「片側にしかない＝アンチ結合」まで、初心者でも壊れないコードを用途別にまとめました。

使い分け早見

  • 左結合（LEFT JOIN）: 明細を基準に、マスタ項目を横付け。未一致は埋める。
  • 内結合（INNER JOIN）: 一致するキーの行だけ出力。
  • 完全結合（FULL OUTER JOIN）: 両側のキーをすべて出し、欠損は補完。
  • 右結合（RIGHT JOIN）: マスタ基準で、明細項目を横付け。
  • アンチ結合（ANTI JOIN）: 片側にしかない行だけ抽出（例：明細にあるがマスタにない）。

いずれも共通の“壊れないコツ”は「キーの正規化」「見出し名で列特定」「配列→辞書→一括貼付」。

下準備ユーティリティ（見出し特定・新シート）

Option Explicit

Private 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

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
  • ポイント
    • 見出し名参照で列順変動に強く、何度実行しても安全に新シートを用意。

左結合（LEFT JOIN）：明細基準でマスタを横付け

「明細A1起点、マスタA1起点。キー＝コード、付与＝名称・単価」の例。

Sub Join_Left()
    '明細: Sheet("明細") … コード/数量
    'マスタ: Sheet("マスタ") … コード/名称/単価
    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = Worksheets("マスタ").Range("A1").CurrentRegion
    Dim vD As Variant: vD = rgD.Value
    Dim vM As Variant: vM = rgM.Value

    '見出し列
    Dim cKeyD As Long: cKeyD = FindHeader(rgD.Rows(1), "コード")
    Dim cQtyD As Long: cQtyD = FindHeader(rgD.Rows(1), "数量")
    Dim cKeyM As Long: cKeyM = FindHeader(rgM.Rows(1), "コード")
    Dim cNameM As Long: cNameM = FindHeader(rgM.Rows(1), "名称")
    Dim cPriceM As Long: cPriceM = FindHeader(rgM.Rows(1), "単価")
    If cKeyD * cQtyD * cKeyM * cNameM * cPriceM = 0 Then MsgBox "見出し不足": Exit Sub

    'マスタ辞書（正規化キー→(名称,単価)）
    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, cKeyM))))
        If Len(k) > 0 Then dict(k) = Array(CStr(vM(i, cNameM)), CDbl(Val(vM(i, cPriceM))))
    Next

    '出力（明細基準）
    Dim out() As Variant: ReDim out(1 To UBound(vD, 1), 1 To 5)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量": out(1, 5) = "金額"

    Dim r As Long
    For r = 2 To UBound(vD, 1)
        Dim kd As String: kd = UCase$(Trim$(CStr(vD(r, cKeyD))))
        Dim qty As Double: qty = CDbl(Val(vD(r, cQtyD)))
        out(r, 1) = vD(r, cKeyD)
        out(r, 4) = qty
        If dict.Exists(kd) Then
            out(r, 2) = dict(kd)(0)
            out(r, 3) = dict(kd)(1)
            out(r, 5) = dict(kd)(1) * qty
        Else
            out(r, 2) = "#N/A": out(r, 3) = 0: out(r, 5) = 0
        End If
    Next

    With EnsureSheet("LEFT_JOIN", True)
        .Range("A1").Resize(UBound(out, 1), UBound(out, 2)).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With
End Sub
VB
  • ポイント
    • 未一致は「#N/A/0」で見える化。
    • 金額は単価×数量をその場で作る。

内結合（INNER JOIN）：一致キーのみ出力

一致する行だけに絞りたいとき。

Sub Join_Inner()
    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = Worksheets("マスタ").Range("A1").CurrentRegion
    Dim vD As Variant: vD = rgD.Value
    Dim vM As Variant: vM = rgM.Value

    Dim cKeyD As Long: cKeyD = FindHeader(rgD.Rows(1), "コード")
    Dim cQtyD As Long: cQtyD = FindHeader(rgD.Rows(1), "数量")
    Dim cKeyM As Long: cKeyM = FindHeader(rgM.Rows(1), "コード")
    Dim cNameM As Long: cNameM = FindHeader(rgM.Rows(1), "名称")
    Dim cPriceM As Long: cPriceM = FindHeader(rgM.Rows(1), "単価")
    If cKeyD * cQtyD * cKeyM * cNameM * cPriceM = 0 Then MsgBox "見出し不足": Exit Sub

    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, cKeyM))))
        dict(k) = Array(CStr(vM(i, cNameM)), CDbl(Val(vM(i, cPriceM))))
    Next

    '件数見積もり（内結合のみ）
    Dim countIn As Long: countIn = 1
    Dim r As Long
    For r = 2 To UBound(vD, 1)
        k = UCase$(Trim$(CStr(vD(r, cKeyD))))
        If dict.Exists(k) Then countIn = countIn + 1
    Next

    Dim out() As Variant: ReDim out(1 To countIn, 1 To 5)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量": out(1, 5) = "金額"

    Dim w As Long: w = 2
    For r = 2 To UBound(vD, 1)
        k = UCase$(Trim$(CStr(vD(r, cKeyD))))
        If dict.Exists(k) Then
            Dim qty As Double: qty = CDbl(Val(vD(r, cQtyD)))
            out(w, 1) = vD(r, cKeyD)
            out(w, 2) = dict(k)(0)
            out(w, 3) = dict(k)(1)
            out(w, 4) = qty
            out(w, 5) = dict(k)(1) * qty
            w = w + 1
        End If
    Next

    With EnsureSheet("INNER_JOIN", True)
        .Range("A1").Resize(countIn, 5).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With
End Sub
VB
  • ポイント
    • 未一致はそもそも行を出さない。
    • 見積もり→配列確保で無駄なく高速。

完全結合（FULL OUTER JOIN）：両側のキーを全部出す

両側の状態を棚卸したい・監査したい場面向け。

Sub Join_FullOuter()
    Dim vA As Variant: vA = Worksheets("明細").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("マスタ").Range("A1").CurrentRegion.Value

    Dim cKeyA As Long: cKeyA = FindHeader(Worksheets("明細").Range("A1").CurrentRegion.Rows(1), "コード")
    Dim cQtyA As Long: cQtyA = FindHeader(Worksheets("明細").Range("A1").CurrentRegion.Rows(1), "数量")
    Dim cKeyB As Long: cKeyB = FindHeader(Worksheets("マスタ").Range("A1").CurrentRegion.Rows(1), "コード")
    Dim cNameB As Long: cNameB = FindHeader(Worksheets("マスタ").Range("A1").CurrentRegion.Rows(1), "名称")
    Dim cPriceB As Long: cPriceB = FindHeader(Worksheets("マスタ").Range("A1").CurrentRegion.Rows(1), "単価")
    If cKeyA * cQtyA * cKeyB * cNameB * cPriceB = 0 Then MsgBox "見出し不足": Exit Sub

    '辞書
    Dim dA As Object: Set dA = CreateObject("Scripting.Dictionary")
    Dim dB As Object: Set dB = 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 dA(k) = Array(vA(i, cKeyA), CDbl(Val(vA(i, cQtyA))))
    Next
    For i = 2 To UBound(vB, 1)
        k = UCase$(Trim$(CStr(vB(i, cKeyB))))
        If Len(k) > 0 Then dB(k) = Array(CStr(vB(i, cNameB)), CDbl(Val(vB(i, cPriceB))))
    Next

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

    '出力
    Dim n As Long: n = all.Count
    Dim out() As Variant: ReDim out(1 To n + 1, 1 To 6)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量": out(1, 5) = "金額": out(1, 6) = "分類"

    Dim r As Long: r = 2
    Dim key As Variant
    For Each key In all.Keys
        Dim hasA As Boolean: hasA = dA.Exists(key)
        Dim hasB As Boolean: hasB = dB.Exists(key)
        out(r, 1) = IIf(hasA, dA(key)(0), key)
        out(r, 2) = IIf(hasB, dB(key)(0), "#N/A")
        out(r, 3) = IIf(hasB, dB(key)(1), 0)
        out(r, 4) = IIf(hasA, dA(key)(1), 0)
        out(r, 5) = IIf(hasA And hasB, dA(key)(1) * dB(key)(1), 0)
        out(r, 6) = IIf(hasA And hasB, "両側", IIf(hasA, "明細のみ", "マスタのみ"))
        r = r + 1
    Next

    With EnsureSheet("FULL_JOIN", True)
        .Range("A1").Resize(n + 1, 6).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With
End Sub
VB
  • ポイント
    • 欠損は明示的に補完し、分類列で可視化。
    • 監査・棚卸に最適。

右結合（RIGHT JOIN）：マスタ基準で明細を横付け

左結合と逆。マスタを“基準側”にしたいとき。

Sub Join_Right()
    '列名はLEFTの逆方向で読み替え
    Dim rgD As Range: Set rgD = Worksheets("明細").Range("A1").CurrentRegion
    Dim rgM As Range: Set rgM = Worksheets("マスタ").Range("A1").CurrentRegion
    Dim vD As Variant: vD = rgD.Value
    Dim vM As Variant: vM = rgM.Value

    Dim cKeyD As Long: cKeyD = FindHeader(rgD.Rows(1), "コード")
    Dim cQtyD As Long: cQtyD = FindHeader(rgD.Rows(1), "数量")
    Dim cKeyM As Long: cKeyM = FindHeader(rgM.Rows(1), "コード")
    Dim cNameM As Long: cNameM = FindHeader(rgM.Rows(1), "名称")
    Dim cPriceM As Long: cPriceM = FindHeader(rgM.Rows(1), "単価")
    If cKeyD * cQtyD * cKeyM * cNameM * cPriceM = 0 Then MsgBox "見出し不足": Exit Sub

    Dim dA As Object: Set dA = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vD, 1)
        k = UCase$(Trim$(CStr(vD(i, cKeyD))))
        dA(k) = CDbl(Val(vD(i, cQtyD)))
    Next

    Dim out() As Variant: ReDim out(1 To UBound(vM, 1), 1 To 5)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "単価": out(1, 4) = "数量": out(1, 5) = "金額"

    Dim r As Long
    For r = 2 To UBound(vM, 1)
        k = UCase$(Trim$(CStr(vM(r, cKeyM))))
        out(r, 1) = vM(r, cKeyM)
        out(r, 2) = vM(r, cNameM)
        out(r, 3) = CDbl(Val(vM(r, cPriceM)))
        Dim qty As Double: qty = IIf(dA.Exists(k), dA(k), 0)
        out(r, 4) = qty
        out(r, 5) = qty * out(r, 3)
    Next

    With EnsureSheet("RIGHT_JOIN", True)
        .Range("A1").Resize(UBound(vM, 1), 5).Value = out
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With
End Sub
VB
  • ポイント
    • マスタが主、明細が従の出力にしたいときに使う。

アンチ結合（ANTI JOIN）：片側だけの行を抽出

JOIN前後の“漏れ”を洗い出すとき。

Sub Join_Anti()
    '明細にあるがマスタに無い（Aのみ）を抽出
    Dim vA As Variant: vA = Worksheets("明細").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("マスタ").Range("A1").CurrentRegion.Value

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

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

    Dim out() As Variant: ReDim out(1 To UBound(vA, 1), 1 To 2)
    out(1, 1) = "コード": out(1, 2) = "名称"
    Dim w As Long: w = 2
    For i = 2 To UBound(vA, 1)
        k = UCase$(Trim$(CStr(vA(i, cKeyA))))
        If Len(k) > 0 And Not setB.Exists(k) Then
            out(w, 1) = vA(i, cKeyA)
            out(w, 2) = vA(i, cNameA)
            w = w + 1
        End If
    Next

    With EnsureSheet("ANTI_JOIN", True)
        If w > 2 Then .Range("A1").Resize(w - 1, 2).Value = out Else .Range("A2").Value = "(未該当)"
        .Rows(1).Font.Bold = True
        .Columns.AutoFit
    End With
End Sub
VB
  • ポイント
    • 逆方向（マスタのみ）も同じ要領で作れる。

例題で練習

'例1：明細基準の左結合
Sub Example_Left()
    Join_Left
End Sub

'例2：一致のみの内結合
Sub Example_Inner()
    Join_Inner
End Sub

'例3：両側を全部出す完全結合
Sub Example_Full()
    Join_FullOuter
End Sub

'例4：マスタ基準の右結合
Sub Example_Right()
    Join_Right
End Sub

'例5：片側のみ（アンチ結合）の抽出
Sub Example_Anti()
    Join_Anti
End Sub
VB

よくある落とし穴と対策

  • キー表記揺れでJOIN漏れ
    • 対策: Trim/UCase を徹底。必要なら半角化・不要記号除去も追加。
  • 列順変更で壊れる
    • 対策: 見出し名で列特定（FindHeader）。ハードコード禁止。
  • 数値が文字列になって並びや計算が狂う
    • 対策: 取り込み時に Val→CDbl で数値化。書式は後で整える。
  • 大規模で遅い
    • 対策: 範囲→配列→辞書→一括貼付。前後で ScreenUpdating=False や計算停止を入れると安定。
スポンサーリンク
タイトルとURLをコピーしました