Excel VBA 逆引き集 | マスタ更新の差分検出

Excel VBA
スポンサーリンク

マスタ更新の差分検出

「前回のマスタと今回のマスタで、どのコードが追加・削除・変更された？」——そんな“差分チェック”を初心者でも壊さず自動化できるテンプレをまとめました。キー一致で行を突き合わせ、項目ごとの差分をわかりやすく出力します。

使い分けの指針

  • 最短・定番: 単一キーで「追加・削除・変更」を3分類して別シートに出力
  • 項目が多い: 比較対象の見出し名を配列で指定して、変更点を行ごとに一覧化
  • 速度重視（大量行）: 範囲→配列→辞書で一括判定、セル往復ゼロで高速
  • 監査重視: 変更前/後の値を同じ行に並べ、どの項目が変わったかも列で出力

基本テンプレ：単一キーで追加・削除・変更を検出

Option Explicit

'見出し名の列番号を取得（列順が変わっても安全）
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 DiffDetect_Basic()
    '旧マスタ: Sheet("旧"), 新マスタ: Sheet("新")
    '共通キー: 「コード」、比較項目: 「名称」「単価」
    Dim wsOld As Worksheet: Set wsOld = Worksheets("旧")
    Dim wsNew As Worksheet: Set wsNew = Worksheets("新")

    Dim rgOld As Range: Set rgOld = wsOld.Range("A1").CurrentRegion
    Dim rgNew As Range: Set rgNew = wsNew.Range("A1").CurrentRegion
    Dim vOld As Variant: vOld = rgOld.Value
    Dim vNew As Variant: vNew = rgNew.Value

    '見出し列番号
    Dim cKeyO As Long: cKeyO = FindHeader(rgOld.Rows(1), "コード")
    Dim cKeyN As Long: cKeyN = FindHeader(rgNew.Rows(1), "コード")
    Dim cNameO As Long: cNameO = FindHeader(rgOld.Rows(1), "名称")
    Dim cNameN As Long: cNameN = FindHeader(rgNew.Rows(1), "名称")
    Dim cPriceO As Long: cPriceO = FindHeader(rgOld.Rows(1), "単価")
    Dim cPriceN As Long: cPriceN = FindHeader(rgNew.Rows(1), "単価")
    If cKeyO * cKeyN * cNameO * cNameN * cPriceO * cPriceN = 0 Then
        MsgBox "見出し不足（コード/名称/単価）": Exit Sub
    End If

    '新マスタ→辞書（キー→(名称,単価)）
    Dim dictNew As Object: Set dictNew = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vNew, 1)
        key = UCase$(Trim$(CStr(vNew(i, cKeyN))))
        If Len(key) > 0 Then dictNew(key) = Array(CStr(vNew(i, cNameN)), CDbl(Val(vNew(i, cPriceN))))
    Next

    '出力シート準備
    Dim wsAdd As Worksheet, wsDel As Worksheet, wsChg As Worksheet
    On Error Resume Next
    Set wsAdd = Worksheets("追加")
    Set wsDel = Worksheets("削除")
    Set wsChg = Worksheets("変更")
    If wsAdd Is Nothing Then Set wsAdd = Worksheets.Add: wsAdd.Name = "追加"
    If wsDel Is Nothing Then Set wsDel = Worksheets.Add: wsDel.Name = "削除"
    If wsChg Is Nothing Then Set wsChg = Worksheets.Add: wsChg.Name = "変更"
    On Error GoTo 0
    wsAdd.Cells.Clear: wsDel.Cells.Clear: wsChg.Cells.Clear

    wsAdd.Range("A1:C1").Value = Array("コード", "名称", "単価（新）")
    wsDel.Range("A1:C1").Value = Array("コード", "名称", "単価（旧）")
    wsChg.Range("A1:E1").Value = Array("コード", "名称（旧）", "名称（新）", "単価（旧）", "単価（新）")

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

    '1) 旧をなめて「削除」「変更」を判定
    For i = 2 To UBound(vOld, 1)
        key = UCase$(Trim$(CStr(vOld(i, cKeyO))))
        If Len(key) = 0 Then GoTo nextOld

        Dim oldName As String: oldName = CStr(vOld(i, cNameO))
        Dim oldPrice As Double: oldPrice = CDbl(Val(vOld(i, cPriceO)))

        If dictNew.Exists(key) Then
            Dim newName As String: newName = CStr(dictNew(key)(0))
            Dim newPrice As Double: newPrice = CDbl(dictNew(key)(1))
            If (oldName <> newName) Or (oldPrice <> newPrice) Then
                wsChg.Cells(rChg, 1).Value = key
                wsChg.Cells(rChg, 2).Value = oldName
                wsChg.Cells(rChg, 3).Value = newName
                wsChg.Cells(rChg, 4).Value = oldPrice
                wsChg.Cells(rChg, 5).Value = newPrice
                rChg = rChg + 1
            End If
        Else
            wsDel.Cells(rDel, 1).Value = key
            wsDel.Cells(rDel, 2).Value = oldName
            wsDel.Cells(rDel, 3).Value = oldPrice
            rDel = rDel + 1
        End If
nextOld:
    Next

    '2) 新をなめて「追加」を判定（旧にないキー）
    Dim presentOld As Object: Set presentOld = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vOld, 1)
        key = UCase$(Trim$(CStr(vOld(i, cKeyO))))
        If Len(key) > 0 Then presentOld(key) = True
    Next

    Dim j As Long
    For j = 2 To UBound(vNew, 1)
        key = UCase$(Trim$(CStr(vNew(j, cKeyN))))
        If Len(key) > 0 And Not presentOld.Exists(key) Then
            wsAdd.Cells(rAdd, 1).Value = key
            wsAdd.Cells(rAdd, 2).Value = CStr(vNew(j, cNameN))
            wsAdd.Cells(rAdd, 3).Value = CDbl(Val(vNew(j, cPriceN)))
            rAdd = rAdd + 1
        End If
    Next

    wsAdd.Columns.AutoFit: wsDel.Columns.AutoFit: wsChg.Columns.AutoFit
End Sub
VB
  • ポイント
    • 3分類: 旧→新にない＝削除、新→旧にない＝追加、両方にあるが値が違う＝変更。
    • 見出し名で列特定: 列順が変わっても壊れない。
    • 正規化: キーは Trim/UCase、数値は Val 経由で比較。

比較項目を柔軟に指定（複数列の変更点を一括判定）

Sub DiffDetect_Flexible()
    '旧/新どちらも「コード」キー。比較したい項目見出しを配列で指定
    Dim wsOld As Worksheet: Set wsOld = Worksheets("旧")
    Dim wsNew As Worksheet: Set wsNew = Worksheets("新")
    Dim rgOld As Range: Set rgOld = wsOld.Range("A1").CurrentRegion
    Dim rgNew As Range: Set rgNew = wsNew.Range("A1").CurrentRegion
    Dim vOld As Variant: vOld = rgOld.Value
    Dim vNew As Variant: vNew = rgNew.Value

    Dim cKeyO As Long: cKeyO = FindHeader(rgOld.Rows(1), "コード")
    Dim cKeyN As Long: cKeyN = FindHeader(rgNew.Rows(1), "コード")
    If cKeyO * cKeyN = 0 Then MsgBox "キー見出し不足": Exit Sub

    '比較項目（例：名称・単価・カテゴリ）
    Dim fields As Variant: fields = Array("名称", "単価", "カテゴリ")

    '旧/新の項目→列番号を対応付け
    Dim mapO() As Long: ReDim mapO(LBound(fields) To UBound(fields))
    Dim mapN() As Long: ReDim mapN(LBound(fields) To UBound(fields))
    Dim i As Long
    For i = LBound(fields) To UBound(fields)
        mapO(i) = FindHeader(rgOld.Rows(1), CStr(fields(i)))
        mapN(i) = FindHeader(rgNew.Rows(1), CStr(fields(i)))
        If mapO(i) = 0 Or mapN(i) = 0 Then
            MsgBox "見出し不足：" & fields(i): Exit Sub
        End If
    Next

    '新辞書（キー→行配列）
    Dim dictNew As Object: Set dictNew = CreateObject("Scripting.Dictionary")
    Dim k As String, r As Long
    For r = 2 To UBound(vNew, 1)
        k = UCase$(Trim$(CStr(vNew(r, cKeyN))))
        If Len(k) > 0 Then dictNew(k) = r
    Next

    '出力
    Dim wsAdd As Worksheet, wsDel As Worksheet, wsChg As Worksheet
    On Error Resume Next
    Set wsAdd = Worksheets("追加"): If wsAdd Is Nothing Then Set wsAdd = Worksheets.Add: wsAdd.Name = "追加"
    Set wsDel = Worksheets("削除"): If wsDel Is Nothing Then Set wsDel = Worksheets.Add: wsDel.Name = "削除"
    Set wsChg = Worksheets("変更"): If wsChg Is Nothing Then Set wsChg = Worksheets.Add: wsChg.Name = "変更"
    On Error GoTo 0
    wsAdd.Cells.Clear: wsDel.Cells.Clear: wsChg.Cells.Clear

    'ヘッダー
    wsAdd.Range("A1").Value = "コード"
    wsDel.Range("A1").Value = "コード"
    wsChg.Range("A1:D1").Value = Array("コード", "項目名", "旧", "新")

    Dim rAdd As Long: rAdd = 2, rDel As Long: rDel = 2, rChg As Long: rChg = 2

    '旧を走査（削除・変更）
    For r = 2 To UBound(vOld, 1)
        k = UCase$(Trim$(CStr(vOld(r, cKeyO))))
        If Len(k) = 0 Then GoTo contOld

        If dictNew.Exists(k) Then
            Dim rn As Long: rn = dictNew(k)
            '項目ごとに差分チェック
            For i = LBound(fields) To UBound(fields)
                Dim vo As Variant: vo = vOld(r, mapO(i))
                Dim vn As Variant: vn = vNew(rn, mapN(i))
                Dim isDiff As Boolean
                '数値っぽい項目名は数値化して比較（任意）
                If fields(i) Like "*単価*" Or fields(i) Like "*金額*" Then
                    isDiff = (CDbl(Val(vo)) <> CDbl(Val(vn)))
                Else
                    isDiff = (CStr(vo) <> CStr(vn))
                End If
                If isDiff Then
                    wsChg.Cells(rChg, 1).Value = k
                    wsChg.Cells(rChg, 2).Value = fields(i)
                    wsChg.Cells(rChg, 3).Value = vo
                    wsChg.Cells(rChg, 4).Value = vn
                    rChg = rChg + 1
                End If
            Next
        Else
            wsDel.Cells(rDel, 1).Value = k
            rDel = rDel + 1
        End If
contOld:
    Next

    '新にだけある＝追加
    Dim presentOld As Object: Set presentOld = CreateObject("Scripting.Dictionary")
    For r = 2 To UBound(vOld, 1)
        k = UCase$(Trim$(CStr(vOld(r, cKeyO))))
        If Len(k) > 0 Then presentOld(k) = True
    Next
    Dim rn2 As Long
    For rn2 = 2 To UBound(vNew, 1)
        k = UCase$(Trim$(CStr(vNew(rn2, cKeyN))))
        If Len(k) > 0 And Not presentOld.Exists(k) Then
            wsAdd.Cells(rAdd, 1).Value = k
            rAdd = rAdd + 1
        End If
    Next

    wsAdd.Columns.AutoFit: wsDel.Columns.AutoFit: wsChg.Columns.AutoFit
End Sub
VB
  • ポイント
    • 項目配列: 比較対象を増減できる。数値項目は数値比較、文字項目は文字比較。
    • 変更一覧の書き方: 1差分＝1行で「項目名・旧・新」を並べると監査しやすい。

爆速：配列＋辞書で一括差分（安全ラップ付き）

Sub DiffDetect_Fast()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    '必要に応じて、上のテンプレ（Basic/Flexible）のロジックをそのまま使う

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント
    • 前後で停止→復帰: 画面更新・イベント・計算を止めると大量行でも安定。
    • ロジックは同じ: 配列と辞書の組み合わせが基本。

よくある落とし穴と対策

  • 見出しが微妙に違う
    • 対策: 見出し名で列特定。別名（コード/商品コード）対応は事前置換か候補検索に。
  • キーの表記揺れで誤判定
    • 対策: Trim/UCase で正規化。必要なら半角化や不要記号除去も。
  • 数値が文字列で比較がズレる
    • 対策: Val 経由で数値化して比較。小数は丸め規則（例：Round）を決める。
  • 空白・Null・エラーセル
    • 対策: CStr や Len で防御。未設定は一致扱いにするか、差分扱いにするか方針を決める。
  • 列順変更・追加で壊れる
    • 対策: 見出し名で列位置を取得（FindHeader）。ハードコードは避ける。

例題で練習

'例1：コード・名称・単価の差分を3分類で出力
Sub Example_DiffBasic()
    DiffDetect_Basic
End Sub

'例2：名称・単価・カテゴリなど複数項目の変更点を一覧化
Sub Example_DiffFlexible()
    DiffDetect_Flexible
End Sub

'例3：大量データでの高速差分（安全ラップ）
Sub Example_DiffFast()
    DiffDetect_Fast
End Sub
VB

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