Excel VBA 逆引き集 | 内部結合

Excel VBA
スポンサーリンク

内部結合

「基準表と相手表の“両方に存在するキーだけ”を横に統合したい」——それが内部結合です。最短の関数版、爆速の辞書版、見出し名対応の安全版、複数キー対応まで、初心者が壊さず使えるテンプレを揃えました。

考え方と使い分け

  • 最短・手軽: VLOOKUPで相手値を付与→一致した行だけ抽出
  • 大量・高速: 配列＋辞書でキーの交差（和集合でなく“共通部分”）を出し、内側だけ出力
  • 列順が変わる: 見出し名から列番号を動的取得して安全に参照
  • 複数キー: ヘルパー列でキー連結（例：部署|年月）して同様の手順

最短テンプレ：VLOOKUP＋一致行のみ抽出（内部結合）

Sub InnerJoin_VLookup()
    '基準: 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 tblO As Range: Set tblO = wsO.Range("A1").CurrentRegion
    Dim lastB As Long: lastB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row

    '一時列にVLOOKUP（相手が存在するものだけ値が入る）
    wsB.Range("Z1").Value = "他合計_tmp"
    With wsB.Range("Z2:Z" & lastB)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC1," & tblO.Address(True, True, xlA1, True) & ",2,FALSE),NA())"
        .Value = .Value '値化
    End With

    '一致行のみ出力（Z列がエラーでない行）
    Dim r As Long, rOut As Long: rOut = 2
    For r = 2 To lastB
        If Not IsError(wsB.Cells(r, "Z").Value) Then
            wsOut.Cells(rOut, 1).Value = wsB.Cells(r, "A").Value
            wsOut.Cells(rOut, 2).Value = wsB.Cells(r, "B").Value
            wsOut.Cells(rOut, 3).Value = wsB.Cells(r, "C").Value
            wsOut.Cells(rOut, 4).Value = wsB.Cells(r, "Z").Value
            rOut = rOut + 1
        End If
    Next

    '後片付け（必要ならZ列削除）
    wsB.Columns("Z").ClearContents

    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 内部結合の定義: 相手に存在するキーだけ通す。VLOOKUP結果がエラーでない行が対象。
    • 値化必須: 式は値化して軽く運用。一時列は最後に消す。

爆速テンプレ：配列＋辞書で内部結合（単一キー）

Sub InnerJoin_Dictionary()
    '基準: A=コード, B=名称, C=合計
    '相手: A=コード, B=他合計
    '出力: 内部結合（両方にあるコードのみ）
    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))))
        If Len(key) > 0 Then dict(key) = Val(vo(i, 2))
    Next

    '基準→配列で読み込み、辞書にあるキーのみ出力配列へ
    Dim vb As Variant: vb = wsB.Range("A1").CurrentRegion.Value
    Dim out() As Variant: ReDim out(1 To UBound(vb, 1), 1 To 4)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "合計": out(1, 4) = "他合計"

    Dim r As Long, w As Long: w = 2
    For r = 2 To UBound(vb, 1)
        key = UCase$(Trim$(CStr(vb(r, 1))))
        If dict.Exists(key) Then
            out(w, 1) = vb(r, 1)
            out(w, 2) = vb(r, 2)
            out(w, 3) = Val(vb(r, 3))
            out(w, 4) = dict(key)
            w = w + 1
        End If
    Next

    '貼り付け（件数w-2に合わせて縮める）
    If w > 2 Then
        wsOut.Range("A1").Resize(w - 1, 4).Value = out
    Else
        wsOut.Range("A2").Value = "(共通キーがありません)"
    End If
    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • キー正規化: Trim/UCaseで揺れ対策。
    • 内部結合は“辞書に存在するか”で判定: 一致のみ出力するから高速・明快。

見出し名で安全に列特定（列順変更に強い）

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

Sub InnerJoin_ByHeaders()
    '見出し名で列位置を取得して内部結合（単一キー）
    Dim wsB As Worksheet: Set wsB = Worksheets("基準")
    Dim wsO As Worksheet: Set wsO = Worksheets("相手")
    Dim rgB As Range: Set rgB = wsB.Range("A1").CurrentRegion
    Dim rgO As Range: Set rgO = wsO.Range("A1").CurrentRegion

    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    Dim cNameB As Long: cNameB = FindHeader(rgB.Rows(1), "名称")
    Dim cSumB As Long: cSumB = FindHeader(rgB.Rows(1), "合計")
    Dim cKeyO As Long: cKeyO = FindHeader(rgO.Rows(1), "コード")
    Dim cValO As Long: cValO = FindHeader(rgO.Rows(1), "他合計")
    If cKeyB * cNameB * cSumB * cKeyO * cValO = 0 Then MsgBox "見出し不足": Exit Sub

    Dim vo As Variant: vo = rgO.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, cKeyO))))
        dict(key) = Val(vo(i, cValO))
    Next

    Dim vb As Variant: vb = rgB.Value
    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 rOut As Long: rOut = 2
    For i = 2 To UBound(vb, 1)
        key = UCase$(Trim$(CStr(vb(i, cKeyB))))
        If dict.Exists(key) Then
            wsOut.Cells(rOut, 1).Value = vb(i, cKeyB)
            wsOut.Cells(rOut, 2).Value = vb(i, cNameB)
            wsOut.Cells(rOut, 3).Value = Val(vb(i, cSumB)
            wsOut.Cells(rOut, 4).Value = dict(key)
            rOut = rOut + 1
        End If
    Next
    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 壊れない列参照: 見出し名で位置特定。列順が入れ替わっても安全。
    • “一致のみ”出力: 内部結合の本質を守る。

複数キーの内部結合（部署×年月など）

Sub InnerJoin_MultiKey()
    '基準: A=部署, B=年月, C=合計
    '相手: A=部署, B=年月, C=他合計
    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("部署", "年月", "合計", "他合計", "キー")

    '相手辞書（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))))
        If dict.Exists(k) Then
            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 = dict(k)
            wsOut.Cells(rOut, 5).Value = k
            rOut = rOut + 1
        End If
    Next
    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • キー連結: "|" のような安全な区切り記号で連結。
    • 年月の型統一: Format$(DateValue(日付),"yyyy-mm") で揃えるとミスが減る。

仕上げの小ワザと落とし穴対策

  • キー正規化の徹底:
    • Trim/UCase: 前後空白や大小文字差の吸収。
    • 半角化や記号除去: 必要なら StrConv(…, vbNarrow)、Replace を追加。
  • 数値の型ズレ:
    • Valで数値化: 式は .Value = .Value で値化して計算ズレ回避。
  • 速度最適化:
    • 安全ラップ: 先頭で Application.ScreenUpdating=False、Calculation=Manual、終了時に復帰。
  • 監査の見える化:
    • キー出力列: 複数キーのときはキー列を出力して突合チェックを容易に。

例題で練習

'例1：VLOOKUPで一致行のみ抽出して内部結合
Sub Example_Inner_VLookup()
    InnerJoin_VLookup
End Sub

'例2：配列＋辞書で高速内部結合（単一キー）
Sub Example_Inner_Dict()
    InnerJoin_Dictionary
End Sub

'例3：見出し名で列特定→安全な内部結合
Sub Example_Inner_ByHeaders()
    InnerJoin_ByHeaders
End Sub

'例4：複数キー（部署×年月）の内部結合
Sub Example_Inner_MultiKey()
    InnerJoin_MultiKey
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました