Excel VBA 逆引き集 | 差分抽出（新規／削除／変更）

Excel VBA
スポンサーリンク

差分抽出（新規／削除／変更）

「前月Aと今月Bの違いを知りたい」「追加・削除・変更の3つに分けて一覧化したい」——初心者でも壊れず速く動く差分抽出テンプレです。コツは「キーの正規化」「見出し名で列特定」「配列＋辞書」「一括貼付」「数値・日付の型を統一」。

差分の考え方（3分類）

  • 新規: BにあってAにない行（A→Bで増えた）
  • 削除: AにあってBにない行（A→Bで消えた）
  • 変更: AとBに同じキーがあるが、項目値が違う行（内容更新）

共通ユーティリティ（速度・安全）

Option Explicit

Private Sub SpeedOn()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Private Sub SpeedOff()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = name
    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

Private Function NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v)))
End Function
VB
  • ポイント
    • 速度: 画面/イベント/計算を停止してから処理→復帰。
    • 見出し名参照: 列順変動に強い、早期検知で安全。
    • キー正規化: Trim＋UCaseで表記揺れを吸収。

単一キーの差分抽出（新規／削除／変更の3シート出力）

AとBの見出しに「コード」「名称」「単価」などがある前提の定番テンプレ。

Sub Diff_Extract_Basic3()
    SpeedOn

    'A: Sheet("A") / B: Sheet("B")
    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), "名称")
    Dim cPriceA As Long: cPriceA = FindHeader(rgA.Rows(1), "単価")
    Dim cPriceB As Long: cPriceB = FindHeader(rgB.Rows(1), "単価")
    If cKeyA*cKeyB*cNameA*cNameB*cPriceA*cPriceB = 0 Then SpeedOff: MsgBox("見出し不足"): Exit Sub

    'B辞書（キー→(名称, 単価)）
    Dim dB As Object: Set dB = CreateObject("Scripting.Dictionary")
    Dim i As Long, k As String
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, cKeyB))
        If Len(k) > 0 Then dB(k) = Array(CStr(vB(i, cNameB)), CDbl(Val(vB(i, cPriceB))))
    Next

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

    '新規（Bのみ）/削除（Aのみ）/変更（両側あるが値違い）
    Dim wsNew As Worksheet: Set wsNew = EnsureSheet("新規(Bのみ)", True)
    Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除(Aのみ)", True)
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(差分)", True)

    wsNew.Range("A1:C1").Value = Array("コード", "名称(B)", "単価(B)")
    wsDel.Range("A1:C1").Value = Array("コード", "名称(A)", "単価(A)")
    wsChg.Range("A1:E1").Value = Array("コード", "項目", "A値", "B値", "備考")

    Dim rNew As Long: rNew = 2
    Dim rDel As Long: rDel = 2
    Dim rChg As Long: rChg = 2

    'A基準で削除・変更を確定
    For i = 2 To UBound(vA, 1)
        k = NormKey(vA(i, cKeyA))
        If Len(k) = 0 Then GoTo nextA

        Dim aName As String: aName = CStr(vA(i, cNameA))
        Dim aPrice As Double: aPrice = CDbl(Val(vA(i, cPriceA)))

        If dB.Exists(k) Then
            Dim bName As String: bName = dB(k)(0)
            Dim bPrice As Double: bPrice = dB(k)(1)

            If aName <> bName Then
                wsChg.Cells(rChg, 1).Value = vA(i, cKeyA)
                wsChg.Cells(rChg, 2).Value = "名称"
                wsChg.Cells(rChg, 3).Value = aName
                wsChg.Cells(rChg, 4).Value = bName
                rChg = rChg + 1
            End If
            If aPrice <> bPrice Then
                wsChg.Cells(rChg, 1).Value = vA(i, cKeyA)
                wsChg.Cells(rChg, 2).Value = "単価"
                wsChg.Cells(rChg, 3).Value = aPrice
                wsChg.Cells(rChg, 4).Value = bPrice
                rChg = rChg + 1
            End If
        Else
            wsDel.Cells(rDel, 1).Value = vA(i, cKeyA)
            wsDel.Cells(rDel, 2).Value = aName
            wsDel.Cells(rDel, 3).Value = aPrice
            rDel = rDel + 1
        End If
nextA:
    Next

    'Bのみ（新規）
    Dim j As Long
    For j = 2 To UBound(vB, 1)
        k = NormKey(vB(j, cKeyB))
        If Len(k) > 0 And Not setA.Exists(k) Then
            wsNew.Cells(rNew, 1).Value = vB(j, cKeyB)
            wsNew.Cells(rNew, 2).Value = vB(j, cNameB)
            wsNew.Cells(rNew, 3).Value = vB(j, cPriceB)
            rNew = rNew + 1
        End If
    Next

    wsNew.Columns.AutoFit: wsDel.Columns.AutoFit: wsChg.Columns.AutoFit
    SpeedOff
End Sub
VB
  • ポイント
    • 3分類を別シート出力: 現場でそのまま配布・起票に使える。
    • 項目別差分: 変更は「項目名×差分」の行に分解すると修正しやすい。

比較項目を柔軟に増減（見出し名配列で指定）

名称・カテゴリ・単価・ステータス…比較項目が増えても見出し名で安全に対応。

Sub Diff_Extract_FlexibleFields()
    SpeedOn

    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), "コード")
    If cKeyA = 0 Or cKeyB = 0 Then SpeedOff: MsgBox "キー見出し不足": Exit Sub

    '比較項目の見出し名リスト
    Dim fields As Variant: fields = Array("名称", "カテゴリ", "単価", "ステータス")

    'A/Bの項目→列番号を取得
    Dim i As Long
    Dim mapA() As Long: ReDim mapA(LBound(fields) To UBound(fields))
    Dim mapB() As Long: ReDim mapB(LBound(fields) To UBound(fields))
    For i = LBound(fields) To UBound(fields)
        mapA(i) = FindHeader(rgA.Rows(1), fields(i))
        mapB(i) = FindHeader(rgB.Rows(1), fields(i))
        If mapA(i) = 0 Or mapB(i) = 0 Then SpeedOff: MsgBox "見出し不足：" & fields(i): Exit Sub
    Next

    'B辞書（キー→行番号）
    Dim dB As Object: Set dB = CreateObject("Scripting.Dictionary")
    Dim r As Long, k As String
    For r = 2 To UBound(vB, 1)
        k = NormKey(vB(r, cKeyB))
        If Len(k) > 0 Then dB(k) = r
    Next

    '出力：変更のみ（項目差分）
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(柔軟)", True)
    wsChg.Range("A1:D1").Value = Array("コード", "項目", "A値", "B値")
    Dim rOut As Long: rOut = 2

    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) = 0 Or Not dB.Exists(k) Then GoTo contA
        Dim rb As Long: rb = dB(k)
        For i = LBound(fields) To UBound(fields)
            Dim va As Variant: va = vA(r, mapA(i))
            Dim vb As Variant: vb = vB(rb, mapB(i))
            Dim diff As Boolean
            If fields(i) Like "*単価*" Or fields(i) Like "*金額*" Then
                diff = (CDbl(Val(va)) <> CDbl(Val(vb)))
            Else
                diff = (CStr(va) <> CStr(vb))
            End If
            If diff Then
                wsChg.Cells(rOut, 1).Value = vA(r, cKeyA)
                wsChg.Cells(rOut, 2).Value = fields(i)
                wsChg.Cells(rOut, 3).Value = va
                wsChg.Cells(rOut, 4).Value = vb
                rOut = rOut + 1
            End If
        Next
contA:
    Next

    '新規・削除も合わせて出す場合（省略せずに必要なら前テンプレと併用）
    wsChg.Columns.AutoFit
    SpeedOff
End Sub
VB
  • ポイント
    • 数値項目は数値比較: 文字列比較の誤判定を防ぐ。
    • 見出し名リスト: 現場で増減しやすい。

複数キー（例：コード×年月）で差分抽出

複合キーを文字連結して、新規／削除、変更（指定項目）を抽出。

Private Function BuildKey2(ByVal code As Variant, ByVal ymd As Variant) As String
    Dim ym As String
    If IsDate(ymd) Then ym = Format$(CDate(ymd), "yyyy-mm") Else ym = CStr(ymd)
    BuildKey2 = NormKey(code) & "|" & UCase$(Trim$(ym))
End Function

Sub Diff_Extract_MultiKey()
    SpeedOn

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

    '辞書（Bの複合キー→(行番号/名称/単価)）
    Dim dB As Object: Set dB = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vB, 1)
        key = BuildKey2(vB(i, 1), vB(i, 2))
        dB(key) = Array(i, CStr(vB(i, 3)), CDbl(Val(vB(i, 4))))
    Next

    'Aキー集合（複合キー）
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        key = BuildKey2(vA(i, 1), vA(i, 2)): setA(key) = True
    Next

    '新規・削除・変更出力
    Dim wsNew As Worksheet: Set wsNew = EnsureSheet("新規(Bのみ)_複合", True)
    Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除(Aのみ)_複合", True)
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(複合差分)", True)

    wsNew.Range("A1:D1").Value = Array("コード", "年月", "名称(B)", "単価(B)")
    wsDel.Range("A1:D1").Value = Array("コード", "年月", "名称(A)", "単価(A)")
    wsChg.Range("A1:E1").Value = Array("コード|年月", "項目", "A値", "B値", "備考")

    Dim rNew As Long: rNew = 2
    Dim rDel As Long: rDel = 2
    Dim rChg As Long: rChg = 2

    'A側ループ：削除・変更
    For i = 2 To UBound(vA, 1)
        key = BuildKey2(vA(i, 1), vA(i, 2))
        Dim aName As String: aName = CStr(vA(i, 3))
        Dim aPrice As Double: aPrice = CDbl(Val(vA(i, 4)))

        If dB.Exists(key) Then
            Dim bName As String: bName = dB(key)(1)
            Dim bPrice As Double: bPrice = dB(key)(2)
            If aName <> bName Then
                wsChg.Cells(rChg, 1).Value = key
                wsChg.Cells(rChg, 2).Value = "名称"
                wsChg.Cells(rChg, 3).Value = aName
                wsChg.Cells(rChg, 4).Value = bName
                rChg = rChg + 1
            End If
            If aPrice <> bPrice Then
                wsChg.Cells(rChg, 1).Value = key
                wsChg.Cells(rChg, 2).Value = "単価"
                wsChg.Cells(rChg, 3).Value = aPrice
                wsChg.Cells(rChg, 4).Value = bPrice
                rChg = rChg + 1
            End If
        Else
            wsDel.Cells(rDel, 1).Value = vA(i, 1)
            wsDel.Cells(rDel, 2).Value = IIf(IsDate(vA(i, 2)), Format$(CDate(vA(i, 2)), "yyyy-mm"), vA(i, 2))
            wsDel.Cells(rDel, 3).Value = aName
            wsDel.Cells(rDel, 4).Value = aPrice
            rDel = rDel + 1
        End If
    Next

    'Bのみ（新規）
    Dim j As Long
    For j = 2 To UBound(vB, 1)
        key = BuildKey2(vB(j, 1), vB(j, 2))
        If Not setA.Exists(key) Then
            wsNew.Cells(rNew, 1).Value = vB(j, 1)
            wsNew.Cells(rNew, 2).Value = IIf(IsDate(vB(j, 2)), Format$(CDate(vB(j, 2)), "yyyy-mm"), vB(j, 2))
            wsNew.Cells(rNew, 3).Value = vB(j, 3)
            wsNew.Cells(rNew, 4).Value = vB(j, 4)
            rNew = rNew + 1
        End If
    Next

    wsNew.Columns.AutoFit: wsDel.Columns.AutoFit: wsChg.Columns.AutoFit
    SpeedOff
End Sub
VB
  • ポイント
    • 年月統一: yyyy-mm固定で揺れを防ぐ。
    • 安全区切り: 複合キーの連結に「|」などを使用。

実務の落とし穴と対策

  • キー表記揺れで誤分類（新規/削除に化ける）
    • 対策: NormKey（Trim＋UCase）。必要なら半角化・記号除去も追加。
  • 数値を文字列として比較して誤検出
    • 対策: 数値項目は Val→CDblで比較。日付は IsDate→Formatで統一。
  • 列順変更で壊れる
    • 対策: FindHeaderで見出し名から列特定。足りなければメッセージで停止。
  • 大量行で遅い
    • 対策: 配列＋辞書＋一括貼付。前後でSpeedOn/Off。差分は項目別に分解して行数を最小化。

例題で練習

'例1：単一キーの新規/削除/変更を3シートに出力
Sub Example_DiffBasic()
    Diff_Extract_Basic3
End Sub

'例2：比較項目を見出し名配列で柔軟に指定（変更一覧）
Sub Example_DiffFlexible()
    Diff_Extract_FlexibleFields
End Sub

'例3：複合キー（コード×年月）で新規/削除/変更を抽出
Sub Example_DiffMultiKey()
    Diff_Extract_MultiKey
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました