Excel VBA 逆引き集 | 左外部結合

Excel VBA
スポンサーリンク

左外部結合

「基準表のキーを基準に、他表の情報を“ある分だけ”横付けしたい（なければ空欄や0）」——それが左外部結合です。初心者でも壊れないように、最短の関数型、堅牢・高速な辞書型、見出し名対応の安全型を用意しました。

使い分けの指針

  • 最短・少量: VLOOKUPを入れて値化（導入が速い）
  • 列増減に強い: INDEX/MATCH（列番号ズレ問題を回避）
  • 大量・高速: 配列＋辞書（10万行でも現実的）
  • 列順が不安: 見出し名から列特定して安全に参照

最短：VLOOKUPで左外部結合（式→値化）

Sub LeftJoin_VLookup()
    '基準: Sheet("基準") A=コード, B=名称, C=合計
    '追加: Sheet("他")   A=コード, B=他合計
    '出力は基準シートのD列に「他合計」を付与

    Dim wsB As Worksheet: Set wsB = Worksheets("基準")
    Dim wsO As Worksheet: Set wsO = Worksheets("他")

    Dim lastB As Long: lastB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
    Dim tblO As Range: Set tblO = wsO.Range("A1").CurrentRegion  'A:B

    wsB.Range("D1").Value = "他合計"
    With wsB.Range("D2:D" & lastB)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC1," & tblO.Address(True, True, xlA1, True) & ",2,FALSE),0)"
        .Value = .Value '値化して式撤去
    End With
End Sub
VB
  • ポイント
    • 見出しを含む範囲を参照: CurrentRegionでA:Bを丸ごと指定。
    • IFERRORで欠損補完: 追加表にないキーは0や空欄に。

堅牢：INDEX/MATCHで左外部結合（列番号不要）

Sub LeftJoin_IndexMatch()
    Dim wsB As Worksheet: Set wsB = Worksheets("基準")
    Dim wsO As Worksheet: Set wsO = Worksheets("他")

    Dim lastB As Long: lastB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
    Dim rngKeyO As Range: Set rngKeyO = wsO.Range("A:A") '追加キー列
    Dim rngValO As Range: Set rngValO = wsO.Range("B:B") '追加値列

    wsB.Range("D1").Value = "他合計"
    With wsB.Range("D2:D" & lastB)
        .FormulaR1C1 = "=IFERROR(INDEX(" & rngValO.Address(True, True, xlA1, True) & _
                         ",MATCH(RC1," & rngKeyO.Address(True, True, xlA1, True) & ",0)),0)"
        .Value = .Value
    End With
End Sub
VB
  • ポイント
    • 列増減に強い: 参照は列範囲に紐付けるので、列を足しても壊れにくい。
    • 値化で軽量運用: 式は貼った直後に値化。

爆速・堅牢：配列＋辞書で左外部結合（大量行向け）

Sub LeftJoin_Dictionary()
    '基準: A=コード, B=名称, C=合計
    '追加: 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))))
        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
    For r = 2 To UBound(vb, 1)
        Dim k As String: k = UCase$(Trim$(CStr(vb(r, 1))))
        out(r, 1) = vb(r, 1)
        out(r, 2) = vb(r, 2)
        out(r, 3) = Val(vb(r, 3))
        out(r, 4) = IIf(dict.Exists(k), dict(k), 0)
    Next

    wsOut.Range("A1").Resize(UBound(out, 1), 4).Value = out
    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 LeftJoin_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))))
        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 = IIf(dict.Exists(key), dict(key), 0)
        rOut = rOut + 1
    Next
    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 列順変動に耐性: Findで列を動的に取得。
    • 欠損補完: ないキーは0や空欄で埋める。

よくある落とし穴と対策

  • キー表記揺れで結合失敗
    • 対策: 正規化: Trim/UCase、必要なら半角化や記号除去。
  • 数値が文字列で合計ずれ
    • 対策: 数値化: Valで安全に数値へ。式は .Value = .Value で値化。
  • 列順変更で壊れる
    • 対策: 見出し名特定: FindHeaderで列取得、INDEX/MATCHを採用。
  • 大規模で遅い
    • 対策: 配列＋辞書: 範囲→配列→辞書→一括貼付。前後で ScreenUpdating/Calculation/Events を停止→復帰。

例題で練習

'例1：VLOOKUPで左外部結合（式→値化）
Sub Example_Left_VLookup()
    LeftJoin_VLookup
End Sub

'例2：INDEX/MATCHで左外部結合（列増減に強い）
Sub Example_Left_IndexMatch()
    LeftJoin_IndexMatch
End Sub

'例3：配列＋辞書で左外部結合（高速）
Sub Example_Left_Dict()
    LeftJoin_Dictionary
End Sub

'例4：見出し名で列特定して安全に左外部結合
Sub Example_Left_ByHeaders()
    LeftJoin_ByHeaders
End Sub
VB

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