Excel VBA 逆引き集 | 差分をマーク

Excel VBA
スポンサーリンク

差分をマーク

差分を「抽出」ではなく、元の表に「印を付ける（色・フラグ・コメント）」テンプレです。壊れないコツは、キーの正規化、見出し名で列特定、配列で比較、セル往復は最小に、そして「何が変わったか」をセルに残すこと。

差分の種類とマークの仕方

  • 新規（Bのみ）:
    フラグ列に“新規”を立てる、行全体を淡緑で塗る、行頭に「＋」マーク。
  • 削除（Aのみ）:
    フラグ列に“削除”を立てる、行全体を淡赤で塗る、行頭に「−」マーク。
  • 変更（値が違う）:
    変更セルを黄色塗り、コメントに「旧→新」を書き、右端に“変更あり”フラグ。

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

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 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で一致漏れ防止。

最短テンプレ：AとBを比較してフラグ・色・コメントで差分をマーク

「Aを基準にBと突合」。Aシートにフラグ列を作り、変更セルは黄色、コメントで旧→新を記録。Bのみは別に“新規”フラグで追記します。

Sub MarkDiff_FlagsColorsComments()
    SpeedOn

    'シート構成（例）
    'A: Sheet("A") … コード, 名称, 単価
    'B: Sheet("B") … コード, 名称, 単価
    Dim wsA As Worksheet: Set wsA = Worksheets("A")
    Dim wsB As Worksheet: Set wsB = Worksheets("B")
    Dim rgA As Range: Set rgA = wsA.Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = wsB.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 cNameA As Long: cNameA = FindHeader(rgA.Rows(1), "名称")
    Dim cPriceA As Long: cPriceA = FindHeader(rgA.Rows(1), "単価")
    Dim cKeyB As Long: cKeyB = FindHeader(rgB.Rows(1), "コード")
    Dim cNameB As Long: cNameB = FindHeader(rgB.Rows(1), "名称")
    Dim cPriceB As Long: cPriceB = FindHeader(rgB.Rows(1), "単価")
    If cKeyA * cNameA * cPriceA * cKeyB * cNameB * cPriceB = 0 Then SpeedOff: MsgBox "見出し不足": Exit Sub

    'A側にフラグ列を作成（最後の列の次）
    Dim flagCol As Long: flagCol = rgA.Columns.Count + rgA.Column
    wsA.Cells(1, flagCol).Value = "差分フラグ"

    'B辞書（キー→行番号）
    Dim mapB As Object: Set mapB = 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 mapB(k) = i
    Next

    '色の用意
    Dim colorChanged As Long: colorChanged = RGB(255, 235, 156) '黄色
    Dim colorDeleted As Long: colorDeleted = RGB(255, 199, 206) '淡赤

    'A基準で「削除・変更」をマーク
    Dim r As Long
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) = 0 Then GoTo contA

        Dim cellName As Range: Set cellName = wsA.Cells(rgA.Row + r - 1, cNameA)
        Dim cellPrice As Range: Set cellPrice = wsA.Cells(rgA.Row + r - 1, cPriceA)
        Dim cellFlag As Range: Set cellFlag = wsA.Cells(rgA.Row + r - 1, flagCol)

        If mapB.Exists(k) Then
            Dim rb As Long: rb = mapB(k)
            '名称比較（文字）
            Dim aName As String: aName = CStr(vA(r, cNameA))
            Dim bName As String: bName = CStr(vB(rb, cNameB))
            If aName <> bName Then
                cellName.Interior.Color = colorChanged
                cellName.AddComment "旧: " & aName & " → 新: " & bName
                cellFlag.Value = AppendFlag(cellFlag.Value, "変更")
            End If
            '単価比較（数値）
            Dim aPrice As Double: aPrice = CDbl(Val(vA(r, cPriceA)))
            Dim bPrice As Double: bPrice = CDbl(Val(vB(rb, cPriceB)))
            If aPrice <> bPrice Then
                cellPrice.Interior.Color = colorChanged
                cellPrice.AddComment "旧: " & aPrice & " → 新: " & bPrice
                cellFlag.Value = AppendFlag(cellFlag.Value, "変更")
            End If
        Else
            'Aのみ＝削除
            wsA.Range(wsA.Cells(rgA.Row + r - 1, rgA.Column), _
                      wsA.Cells(rgA.Row + r - 1, rgA.Column + rgA.Columns.Count - 1)).Interior.Color = colorDeleted
            cellFlag.Value = AppendFlag(cellFlag.Value, "削除")
        End If
contA:
    Next

    'Bのみ＝新規をB側にフラグ列でマーク（必要ならAへコピーしてマークでも可）
    Dim flagColB As Long: flagColB = rgB.Columns.Count + rgB.Column
    wsB.Cells(1, flagColB).Value = "差分フラグ"
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) > 0 Then setA(k) = True
    Next
    Dim colorNew As Long: colorNew = RGB(198, 239, 206) '淡緑
    For i = 2 To UBound(vB, 1)
        k = NormKey(vB(i, cKeyB))
        If Len(k) > 0 And Not setA.Exists(k) Then
            wsB.Range(wsB.Cells(rgB.Row + i - 1, rgB.Column), _
                      wsB.Cells(rgB.Row + i - 1, rgB.Column + rgB.Columns.Count - 1)).Interior.Color = colorNew
            wsB.Cells(rgB.Row + i - 1, flagColB).Value = AppendFlag(wsB.Cells(rgB.Row + i - 1, flagColB).Value, "新規")
        End If
    Next

    '見やすさ
    wsA.Rows(1).Font.Bold = True: wsB.Rows(1).Font.Bold = True
    wsA.Columns.AutoFit: wsB.Columns.AutoFit

    SpeedOff
End Sub

Private Function AppendFlag(ByVal cur As Variant, ByVal add As String) As String
    Dim s As String: s = Trim$(CStr(cur))
    AppendFlag = IIf(s = "", add, s & "," & add)
End Function
VB
  • ポイント
    • 現場で使いやすい痕跡: セルを塗る＋コメントで「旧→新」を残す。フラグ列は後で並べ替え・抽出に使える。
    • 比較の型: 数値は Val→CDbl、文字は CStr。型ズレで誤判定しない。

比較項目を増減できる柔軟テンプレ（見出し名で指定）

「名称・カテゴリ・単価・ステータス…」など任意項目を配列で指定。変更セルを色付け・コメントでマーク。

Sub MarkDiff_FlexibleFields()
    SpeedOn

    Dim wsA As Worksheet: Set wsA = Worksheets("A")
    Dim wsB As Worksheet: Set wsB = Worksheets("B")
    Dim rgA As Range: Set rgA = wsA.Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = wsB.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("名称", "カテゴリ", "単価", "ステータス")

    '項目→列番号のマップ
    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 mapBRow As Object: Set mapBRow = 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 mapBRow(k) = r
    Next

    'フラグ列
    Dim flagCol As Long: flagCol = rgA.Columns.Count + rgA.Column
    wsA.Cells(1, flagCol).Value = "差分フラグ"

    Dim colorChanged As Long: colorChanged = RGB(255, 235, 156)

    'Aループ：変更セルをマーク
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) = 0 Or Not mapBRow.Exists(k) Then GoTo contA
        Dim rb As Long: rb = mapBRow(k)

        Dim changed As Boolean: changed = False
        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 isNum As Boolean: isNum = (fields(i) Like "*単価*" Or fields(i) Like "*金額*")
            Dim diff As Boolean
            If isNum Then
                diff = (CDbl(Val(va)) <> CDbl(Val(vb)))
            Else
                diff = (CStr(va) <> CStr(vb))
            End If

            If diff Then
                Dim cellA As Range: Set cellA = wsA.Cells(rgA.Row + r - 1, mapA(i))
                cellA.Interior.Color = colorChanged
                cellA.AddComment fields(i) & " 旧: " & va & " → 新: " & vb
                changed = True
            End If
        Next

        If changed Then
            wsA.Cells(rgA.Row + r - 1, flagCol).Value = AppendFlag(wsA.Cells(rgA.Row + r - 1, flagCol).Value, "変更")
        End If
contA:
    Next

    wsA.Rows(1).Font.Bold = True
    wsA.Columns.AutoFit
    SpeedOff
End Sub
VB
  • ポイント
    • 数値項目は数値比較: フォーマットではなく中身で比較。
    • コメントの項目名明記: どの項目が変わったか一目で分かる。

複合キー（例：コード×年月）の差分マーク

年月でバージョンが変わる場合などに。キーを「コード|yyyy-mm」に連結して比較。

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 MarkDiff_MultiKey()
    SpeedOn

    Dim wsA As Worksheet: Set wsA = Worksheets("A")
    Dim wsB As Worksheet: Set wsB = Worksheets("B")
    Dim rgA As Range: Set rgA = wsA.Range("A1").CurrentRegion
    Dim rgB As Range: Set rgB = wsB.Range("A1").CurrentRegion
    Dim vA As Variant: vA = rgA.Value
    Dim vB As Variant: vB = rgB.Value

    '列想定：A=コード, B=年月, C=名称, D=単価（必要ならFindHeaderで置換）
    Dim colorChanged As Long: colorChanged = RGB(255, 235, 156)
    Dim flagColA As Long: flagColA = rgA.Columns.Count + rgA.Column
    Dim flagColB As Long: flagColB = rgB.Columns.Count + rgB.Column
    wsA.Cells(1, flagColA).Value = "差分フラグ"
    wsB.Cells(1, flagColB).Value = "差分フラグ"

    'B辞書（複合キー→行）
    Dim mapB As Object: Set mapB = 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))
        mapB(key) = i
    Next

    'Aループ：削除・変更
    For i = 2 To UBound(vA, 1)
        key = BuildKey2(vA(i, 1), vA(i, 2))
        Dim rowA As Long: rowA = rgA.Row + i - 1
        If mapB.Exists(key) Then
            Dim rb As Long: rb = mapB(key)
            '名称
            If CStr(vA(i, 3)) <> CStr(vB(rb, 3)) Then
                wsA.Cells(rowA, rgA.Column + 2).Interior.Color = colorChanged
                wsA.Cells(rowA, rgA.Column + 2).AddComment "旧: " & vA(i, 3) & " → 新: " & vB(rb, 3)
                wsA.Cells(rowA, flagColA).Value = AppendFlag(wsA.Cells(rowA, flagColA).Value, "変更")
            End If
            '単価
            If CDbl(Val(vA(i, 4))) <> CDbl(Val(vB(rb, 4))) Then
                wsA.Cells(rowA, rgA.Column + 3).Interior.Color = colorChanged
                wsA.Cells(rowA, rgA.Column + 3).AddComment "旧: " & vA(i, 4) & " → 新: " & vB(rb, 4)
                wsA.Cells(rowA, flagColA).Value = AppendFlag(wsA.Cells(rowA, flagColA).Value, "変更")
            End If
        Else
            'Aのみ＝削除
            wsA.Rows(rowA).Interior.Color = RGB(255, 199, 206)
            wsA.Cells(rowA, flagColA).Value = AppendFlag(wsA.Cells(rowA, flagColA).Value, "削除")
        End If
    Next

    'Bのみ＝新規
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(vA, 1)
        setA(BuildKey2(vA(i, 1), vA(i, 2))) = True
    Next
    For i = 2 To UBound(vB, 1)
        key = BuildKey2(vB(i, 1), vB(i, 2))
        If Not setA.Exists(key) Then
            Dim rowB As Long: rowB = rgB.Row + i - 1
            wsB.Rows(rowB).Interior.Color = RGB(198, 239, 206)
            wsB.Cells(rowB, flagColB).Value = AppendFlag(wsB.Cells(rowB, flagColB).Value, "新規")
        End If
    Next

    wsA.Columns.AutoFit: wsB.Columns.AutoFit
    SpeedOff
End Sub
VB
  • ポイント
    • 年月を yyyy-mm 統一: 揺れを防ぐ。
    • 安全区切り: 複合キーは「|」連結が無難。

実務の落とし穴と対策

  • コメントが大量で重くなる
    • 対策: コメントの代わりに「隣列に“旧→新”テキスト」を書く運用も可。監査後にコメント削除ルーチンを用意。
  • 塗り色が既存の色とぶつかる
    • 対策: 差分用の色パレットを決める。塗り前に既存色を退避したい場合は別列に色コード保存。
  • 型ズレで誤判定
    • 対策: 数値は Val→CDbl、日付は IsDate→Format、文字は CStr。比較の型ルールを固定。
  • 列順の変更で壊れる
    • 対策: 可能なら FindHeader を使い、見出しから列位置を特定。

例題で練習

'例1：基本（フラグ＋色＋コメントで差分マーク）
Sub Example_MarkBasic()
    MarkDiff_FlagsColorsComments
End Sub

'例2：見出し名で比較項目を柔軟に指定して差分マーク
Sub Example_MarkFlexible()
    MarkDiff_FlexibleFields
End Sub

'例3：複合キー（コード×年月）の差分マーク
Sub Example_MarkMultiKey()
    MarkDiff_MultiKey
End Sub
VB

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