Excel VBA 逆引き集 | 完全結合

Excel VBA
スポンサーリンク

完全結合（フル外部結合）

「基準表と相手表の両方にあるキーは統合、片方だけにあるキーも残す」——それが完全結合（フル外部結合）です。左外部結合＋右外部結合を合わせたイメージで、両方のキーを“全部”出すのがポイントです。初心者でも壊れないように、関数型・辞書型・見出し名対応のテンプレを用意しました。

考え方と使い分け

  • 最短: 左外部＋右外部を作って結合（VLOOKUPで両側補完）
  • 大量・高速: 配列＋辞書でキーの和集合を作り、両側の値を横付け
  • 列順が変わる: 見出し名から列番号を動的取得して安全に参照
  • 複数キー: ヘルパー列でキー連結（例：部署|年月）

最短テンプレ：VLOOKUPで両側補完（完全結合）

Sub FullJoin_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 rgB As Range: Set rgB = wsB.Range("A1").CurrentRegion
    Dim lastB As Long: lastB = rgB.Rows.Count
    wsOut.Range("A2").Resize(lastB - 1, rgB.Columns.Count).Value = rgB.Offset(1).Resize(lastB - 1).Value

    '相手表の範囲
    Dim rgO As Range: Set rgO = wsO.Range("A1").CurrentRegion
    Dim lastO As Long: lastO = rgO.Rows.Count

    '基準側に相手値をVLOOKUPで付与
    With wsOut.Range("D2:D" & lastB)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC1," & rgO.Address(True, True, xlA1, True) & ",2,FALSE),0)"
        .Value = .Value
    End With

    '相手表にしかないキーを追加（右外部分）
    Dim dictB As Object: Set dictB = CreateObject("Scripting.Dictionary")
    Dim i As Long
    For i = 2 To lastB
        dictB(UCase$(Trim$(CStr(wsOut.Cells(i, 1).Value)))) = True
    Next

    Dim rOut As Long: rOut = lastB + 1
    For i = 2 To lastO
        Dim k As String: k = UCase$(Trim$(CStr(wsO.Cells(i, 1).Value)))
        If Not dictB.Exists(k) Then
            wsOut.Cells(rOut, 1).Value = wsO.Cells(i, 1).Value
            wsOut.Cells(rOut, 4).Value = wsO.Cells(i, 2).Value
            rOut = rOut + 1
        End If
    Next

    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 左外部＋右外部を組み合わせて完全結合。
    • 相手にしかないキーは後から追記。

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

Sub FullJoin_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 vb As Variant: vb = wsB.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 vo As Variant: vo = wsO.Range("A1").CurrentRegion.Value
    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 n As Long: n = all.Count
    Dim out() As Variant: ReDim out(1 To n + 1, 1 To 4)
    out(1, 1) = "コード": out(1, 2) = "名称": out(1, 3) = "合計": out(1, 4) = "他合計"

    Dim rOut As Long: rOut = 2
    For Each key In all.Keys
        out(rOut, 1) = key
        out(rOut, 2) = IIf(base.Exists(key), base(key)(0), "")
        out(rOut, 3) = IIf(base.Exists(key), base(key)(1), 0)
        out(rOut, 4) = IIf(other.Exists(key), other(key), 0)
        rOut = rOut + 1
    Next

    wsOut.Range("A1").Resize(n + 1, 4).Value = out
    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

Sub FullJoin_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 vb As Variant: vb = rgB.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, cKeyB))))
        base(key) = Array(CStr(vb(i, cNameB)), Val(vb(i, cSumB)))
    Next

    '相手辞書（コード→他合計）
    Dim vo As Variant: vo = rgO.Value
    Dim other As Object: Set other = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vo, 1)
        key = UCase$(Trim$(CStr(vo(i, cKeyO))))
        other(key) = Val(vo(i, cValO))
    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 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
    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

解説（初心者向け）

  • 完全結合の定義:
    両方の表にあるキーは統合、片方だけにあるキーも残す。
    →「キーの和集合」を作るのがポイント。
  • 見出し名で列特定:
    列順が変わっても壊れないように FindHeader 関数で列番号を取得。
  • 辞書で高速処理:
    • 基準表 → base(キー) = (名称, 合計)
    • 相手表 → other(キー) = 他合計
    • 和集合 → all.Keys をループして両側の値を出力。
  • 補完:
    • 基準にないキー → 名称は空欄、合計は0
    • 相手にないキー → 他合計は0

例題で練習

'例1：VLOOKUPで完全結合
Sub Example_Full_VLookup()
    FullJoin_VLookup
End Sub

'例2：配列＋辞書で完全結合（高速）
Sub Example_Full_Dict()
    FullJoin_Dictionary
End Sub

'例3：見出し名で列特定して完全結合（列順変更に強い）
Sub Example_Full_ByHeaders()
    FullJoin_ByHeaders
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました