Excel VBA 逆引き集 | 片方にしかない行の抽出

Excel VBA
スポンサーリンク

片方にしかない行の抽出

「A表にはあるけどB表にはない」「B表にはあるけどA表にはない」——片側限定の行を抜き出す基本は“キー集合の差分”です。初心者でも壊れないように、最短の関数法、爆速の辞書法、見出し名対応、複数キー対応までまとめました。

ゴールを明確にする

  • 目的: Aのみ、Bのみの行をそれぞれ抽出して新シートに出す。
  • キー: 代表値（例：コード）。複数キーなら「コード|年月」などで連結。
  • 並び替え不要: 抽出はキーの有無で決めるので並び順は関係ない。

最短テンプレ：COUNTIF/VLOOKUP で片側のみを抽出（式→値化）

式で判定してから値化すれば、初心者でも安全に扱えます。

Sub ExtractOneSide_Formula()
    'A: Sheet("A") A=コード, B=名称
    'B: Sheet("B") A=コード, B=名称
    '出力: Sheet("Aのみ"), Sheet("Bのみ")

    Dim wsA As Worksheet: Set wsA = Worksheets("A")
    Dim wsB As Worksheet: Set wsB = Worksheets("B")
    Dim wsAO As Worksheet, wsBO As Worksheet
    On Error Resume Next
    Set wsAO = Worksheets("Aのみ"): If wsAO Is Nothing Then Set wsAO = Worksheets.Add: wsAO.Name = "Aのみ"
    Set wsBO = Worksheets("Bのみ"): If wsBO Is Nothing Then Set wsBO = Worksheets.Add: wsBO.Name = "Bのみ"
    On Error GoTo 0
    wsAO.Cells.Clear: wsBO.Cells.Clear

    'Aのみ抽出
    Dim lastA As Long: lastA = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
    Dim rngB As Range: Set rngB = wsB.Range("A1").CurrentRegion.Columns(1)
    wsA.Range("C1").Value = "Bに存在?（0=無）"
    With wsA.Range("C2:C" & lastA)
        .FormulaR1C1 = "=COUNTIF(" & rngB.Address(True, True, xlA1, True) & ",RC1)"
        .Value = .Value
    End With
    'C列=0の行のみコピー
    wsAO.Range("A1:B1").Value = Array("コード", "名称")
    Dim r As Long, outRow As Long: outRow = 2
    For r = 2 To lastA
        If wsA.Cells(r, "C").Value = 0 Then
            wsAO.Cells(outRow, 1).Value = wsA.Cells(r, "A").Value
            wsAO.Cells(outRow, 2).Value = wsA.Cells(r, "B").Value
            outRow = outRow + 1
        End If
    Next
    wsA.Columns("C").ClearContents
    wsAO.Columns.AutoFit

    'Bのみ抽出（Aに同様の判定）
    Dim lastB As Long: lastB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
    Dim rngA As Range: Set rngA = wsA.Range("A1").CurrentRegion.Columns(1)
    wsB.Range("C1").Value = "Aに存在?（0=無）"
    With wsB.Range("C2:C" & lastB)
        .FormulaR1C1 = "=COUNTIF(" & rngA.Address(True, True, xlA1, True) & ",RC1)"
        .Value = .Value
    End With
    outRow = 2
    wsBO.Range("A1:B1").Value = Array("コード", "名称")
    For r = 2 To lastB
        If wsB.Cells(r, "C").Value = 0 Then
            wsBO.Cells(outRow, 1).Value = wsB.Cells(r, "A").Value
            wsBO.Cells(outRow, 2).Value = wsB.Cells(r, "B").Value
            outRow = outRow + 1
        End If
    Next
    wsB.Columns("C").ClearContents
    wsBO.Columns.AutoFit
End Sub
VB
  • ポイント
    • COUNTIFで存在判定: 0なら相手に無い＝片側のみ。
    • 値化して軽量化: 判定式は貼ってすぐ .Value = .Value。
    • 一時列は片付け: C列は最後に消す。

爆速テンプレ：配列＋辞書で片側のみ抽出（10万行でも実用）

セル往復ゼロで「キー集合の差」を出します。

Sub ExtractOneSide_Dictionary()
    'A/Bは A=コード, B=名称 を想定
    Dim wsA As Worksheet: Set wsA = Worksheets("A")
    Dim wsB As Worksheet: Set wsB = Worksheets("B")
    Dim vA As Variant: vA = wsA.Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = wsB.Range("A1").CurrentRegion.Value

    'Bキー集合
    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, 1))))
        If Len(k) > 0 Then setB(k) = True
    Next

    'Aのみ出力配列
    Dim outA() As Variant: ReDim outA(1 To UBound(vA, 1), 1 To 2)
    outA(1, 1) = "コード": outA(1, 2) = "名称"
    Dim w As Long: w = 2
    For i = 2 To UBound(vA, 1)
        k = UCase$(Trim$(CStr(vA(i, 1))))
        If Len(k) > 0 And Not setB.Exists(k) Then
            outA(w, 1) = vA(i, 1): outA(w, 2) = vA(i, 2): w = w + 1
        End If
    Next

    'Aのみ貼付
    Dim wsAO As Worksheet: Set wsAO = EnsureSheet("Aのみ", True)
    If w > 2 Then wsAO.Range("A1").Resize(w - 1, 2).Value = outA Else wsAO.Range("A2").Value = "(Aのみなし)"
    wsAO.Columns.AutoFit

    'Aキー集合
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        k = UCase$(Trim$(CStr(vA(i, 1))))
        If Len(k) > 0 Then setA(k) = True
    Next

    'Bのみ出力配列
    Dim outB() As Variant: ReDim outB(1 To UBound(vB, 1), 1 To 2)
    outB(1, 1) = "コード": outB(1, 2) = "名称"
    w = 2
    For i = 2 To UBound(vB, 1)
        k = UCase$(Trim$(CStr(vB(i, 1))))
        If Len(k) > 0 And Not setA.Exists(k) Then
            outB(w, 1) = vB(i, 1): outB(w, 2) = vB(i, 2): w = w + 1
        End If
    Next

    Dim wsBO As Worksheet: Set wsBO = EnsureSheet("Bのみ", True)
    If w > 2 Then wsBO.Range("A1").Resize(w - 1, 2).Value = outB Else wsBO.Range("A2").Value = "(Bのみなし)"
    wsBO.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 ExtractOneSide_ByHeaders()
    Dim rgA As Range: Set rgA = Worksheets("A").Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = Worksheets("B").Range("A1").CurrentRegion
    Dim vA As Variant: vA = rgA.Value
    Dim vB As Variant: vB = rgB.Value

    Dim cKeyA As Long: cKeyA = FindHeader(rgA.Rows(1), "コード")
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    Dim cNameA As Long: cNameA = FindHeader(rgA.Rows(1), "名称")
    Dim cNameB As Long: cNameB = FindHeader(rgB.Rows(1), "名称")
    If cKeyA * cKeyB * cNameA * cNameB = 0 Then MsgBox "見出し不足": Exit Sub

    'Bキー集合
    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))))
        If Len(k) > 0 Then setB(k) = True
    Next

    'Aのみ
    Dim outA() As Variant: ReDim outA(1 To UBound(vA, 1), 1 To 2)
    outA(1, 1) = "コード": outA(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
            outA(w, 1) = vA(i, cKeyA)
            outA(w, 2) = vA(i, cNameA)
            w = w + 1
        End If
    Next
    Dim wsAO As Worksheet: Set wsAO = EnsureSheet("Aのみ", True)
    If w > 2 Then wsAO.Range("A1").Resize(w - 1, 2).Value = outA Else wsAO.Range("A2").Value = "(Aのみなし)"

    'Aキー集合
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        k = UCase$(Trim$(CStr(vA(i, cKeyA))))
        If Len(k) > 0 Then setA(k) = True
    Next

    'Bのみ
    Dim outB() As Variant: ReDim outB(1 To UBound(vB, 1), 1 To 2)
    outB(1, 1) = "コード": outB(1, 2) = "名称"
    w = 2
    For i = 2 To UBound(vB, 1)
        k = UCase$(Trim$(CStr(vB(i, cKeyB))))
        If Len(k) > 0 And Not setA.Exists(k) Then
            outB(w, 1) = vB(i, cKeyB)
            outB(w, 2) = vB(i, cNameB)
            w = w + 1
        End If
    Next
    Dim wsBO As Worksheet: Set wsBO = EnsureSheet("Bのみ", True)
    If w > 2 Then wsBO.Range("A1").Resize(w - 1, 2).Value = outB Else wsBO.Range("A2").Value = "(Bのみなし)"
    wsAO.Columns.AutoFit: wsBO.Columns.AutoFit
End Sub
VB
  • ポイント
    • 壊れない列参照: 見出し名で特定。
    • 早期検知: 見出し不足ならメッセージで停止。

複数キー対応（例：コード×年月 の片側のみ）

キーを連結して集合差を取ります。

Sub ExtractOneSide_MultiKey()
    'A: A=コード, B=年月, C=名称
    'B: A=コード, B=年月, C=名称
    Dim vA As Variant: vA = Worksheets("A").Range("A1").CurrentRegion.Value
    Dim vB As Variant: vB = Worksheets("B").Range("A1").CurrentRegion.Value

    'Bキー集合（key="コード|yyyy-mm"）
    Dim setB As Object: Set setB = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String, ym As String
    For i = 2 To UBound(vB, 1)
        ym = IIf(IsDate(vB(i, 2)), Format$(CDate(vB(i, 2)), "yyyy-mm"), CStr(vB(i, 2)))
        k = UCase$(Trim$(CStr(vB(i, 1)))) & "|" & UCase$(Trim$(ym))
        setB(k) = True
    Next

    'Aのみ
    Dim outA() As Variant: ReDim outA(1 To UBound(vA, 1), 1 To 3)
    outA(1, 1) = "コード": outA(1, 2) = "年月": outA(1, 3) = "名称"
    Dim w As Long: w = 2
    For i = 2 To UBound(vA, 1)
        ym = IIf(IsDate(vA(i, 2)), Format$(CDate(vA(i, 2)), "yyyy-mm"), CStr(vA(i, 2)))
        k = UCase$(Trim$(CStr(vA(i, 1)))) & "|" & UCase$(Trim$(ym))
        If Not setB.Exists(k) Then
            outA(w, 1) = vA(i, 1): outA(w, 2) = ym: outA(w, 3) = vA(i, 3)
            w = w + 1
        End If
    Next
    Dim wsAO As Worksheet: Set wsAO = EnsureSheet("Aのみ_複数キー", True)
    If w > 2 Then wsAO.Range("A1").Resize(w - 1, 3).Value = outA Else wsAO.Range("A2").Value = "(Aのみなし)"
    wsAO.Columns.AutoFit

    'Aキー集合
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        ym = IIf(IsDate(vA(i, 2)), Format$(CDate(vA(i, 2)), "yyyy-mm"), CStr(vA(i, 2)))
        k = UCase$(Trim$(CStr(vA(i, 1)))) & "|" & UCase$(Trim$(ym))
        setA(k) = True
    Next

    'Bのみ
    Dim outB() As Variant: ReDim outB(1 To UBound(vB, 1), 1 To 3)
    outB(1, 1) = "コード": outB(1, 2) = "年月": outB(1, 3) = "名称"
    w = 2
    For i = 2 To UBound(vB, 1)
        ym = IIf(IsDate(vB(i, 2)), Format$(CDate(vB(i, 2)), "yyyy-mm"), CStr(vB(i, 2)))
        k = UCase$(Trim$(CStr(vB(i, 1)))) & "|" & UCase$(Trim$(ym))
        If Not setA.Exists(k) Then
            outB(w, 1) = vB(i, 1): outB(w, 2) = ym: outB(w, 3) = vB(i, 3)
            w = w + 1
        End If
    Next
    Dim wsBO As Worksheet: Set wsBO = EnsureSheet("Bのみ_複数キー", True)
    If w > 2 Then wsBO.Range("A1").Resize(w - 1, 3).Value = outB Else wsBO.Range("A2").Value = "(Bのみなし)"
    wsBO.Columns.AutoFit
End Sub
VB
  • ポイント
    • 年月統一: yyyy-mm で揺れを防ぐ。
    • 区切り文字: "|" のような安全な記号を使う。

ユーティリティ：新シートの安全作成

Public 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
VB
  • ポイント
    • 何度でも安全: あればクリア、なければ新規作成。
    • 追記運用: クリアしたくないなら clear:=False。

よくある落とし穴と対策

  • キー表記揺れで誤検出
    • 対策: 正規化: Trim/UCase、必要なら半角化（StrConv(..., vbNarrow)）や記号除去。
  • 重複キーが混じっている
    • 対策: 抽出前に重複監査用の辞書を作り、別シートに出すと安心。
  • 日付型が混在
    • 対策: IsDate→Format$("yyyy-mm") で統一。
  • 列順変更で壊れる
    • 対策: 見出し名で列特定（FindHeader）。

例題で練習

'例1：式で Aのみ/Bのみを抽出
Sub Example_Formula()
    ExtractOneSide_Formula
End Sub

'例2：辞書で高速に Aのみ/Bのみを抽出
Sub Example_Dictionary()
    ExtractOneSide_Dictionary
End Sub

'例3：見出し名で安全に抽出（列順変更に強い）
Sub Example_ByHeaders()
    ExtractOneSide_ByHeaders
End Sub

'例4：複数キー（コード×年月）の片側抽出
Sub Example_MultiKey()
    ExtractOneSide_MultiKey
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました