先月と今月の一覧の差分を抽出する（追加・削除・変更を Dictionary で判定して色分け）

どんな場面で使うか

毎月届く取引先マスタや社員名簿、商品の価格表について「先月から何が変わったか」を確認する作業は、目視で行うと時間がかかり、見落としも起きやすい作業です。行の順番が月によって違うと、2つのシートを並べて見比べるのはさらに難しくなります。

コード（社員番号や商品コードなど、行を一意に特定できる列）をキーにして Dictionary で突き合わせると、行の順番に関係なく「追加」「削除」「変更」を機械的に判定できます。変更点を一覧にしておけば、確認の記録としても残せます。

判定の考え方

「先月」シートと「今月」シートは同じ列構成で、A列にキー、B列以降に項目が並んでいるとします。判定は次の3つです。

• 追加：今月にあって先月にないキー
• 削除：先月にあって今月にないキー
• 変更：両方にあるが、B列以降のいずれかの値が違うキー

コード

先月のデータを Dictionary に「キー → 行番号」で登録し、今月のデータを1行ずつ照合します。照合できた先月のキーは Dictionary から削除していき、最後に残ったものを「削除」と判定します。結果は「差分」シートに一覧で書き出し、今月のシートでは追加行を黄色、変更されたセルを薄い赤で塗ります。

Sub DiffTables()
    Dim wsOld As Worksheet, wsNew As Worksheet, wsOut As Worksheet
    Dim oldArr As Variant, newArr As Variant, hdr As Variant
    Dim dic As Object, k As Variant
    Dim oldLast As Long, newLast As Long, lastCol As Long
    Dim i As Long, c As Long, outRow As Long, oldIdx As Long

    Set wsOld = ThisWorkbook.Worksheets("先月")
    Set wsNew = ThisWorkbook.Worksheets("今月")
    Set wsOut = ThisWorkbook.Worksheets("差分")
    oldLast = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
    newLast = wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row
    lastCol = wsNew.Cells(1, wsNew.Columns.Count).End(xlToLeft).Column
    If oldLast < 2 Or newLast < 2 Then
        MsgBox "どちらかのシートにデータがありません"
        Exit Sub
    End If

    oldArr = wsOld.Range("A1").Resize(oldLast, lastCol).Value
    newArr = wsNew.Range("A1").Resize(newLast, lastCol).Value
    hdr = wsNew.Range("A1").Resize(1, lastCol).Value

    Set dic = CreateObject("Scripting.Dictionary")
    For i = 2 To oldLast
        k = ToText(oldArr(i, 1))
        If k <> "" And Not dic.Exists(k) Then dic.Add k, i     ' キー → 先月の行番号
    Next i

    wsOut.Cells.Clear
    wsOut.Range("A1:E1").Value = Array("区分", "キー", "項目", "先月", "今月")
    outRow = 2
    wsNew.Range("A2").Resize(newLast - 1, lastCol).Interior.ColorIndex = xlNone

    For i = 2 To newLast
        k = ToText(newArr(i, 1))
        If k <> "" Then
            If dic.Exists(k) Then
                oldIdx = dic(k)
                For c = 2 To lastCol
                    If ToText(oldArr(oldIdx, c)) <> ToText(newArr(i, c)) Then
                        wsOut.Cells(outRow, 1).Resize(1, 5).Value = Array("変更", k, _
                            hdr(1, c), ToText(oldArr(oldIdx, c)), ToText(newArr(i, c)))
                        wsNew.Cells(i, c).Interior.Color = RGB(255, 210, 210)
                        outRow = outRow + 1
                    End If
                Next c
                dic.Remove k                                  ' 照合済みは取り除く
            Else
                wsOut.Cells(outRow, 1).Resize(1, 2).Value = Array("追加", k)
                wsNew.Cells(i, 1).Resize(1, lastCol).Interior.Color = RGB(255, 245, 160)
                outRow = outRow + 1
            End If
        End If
    Next i

    For Each k In dic.Keys                                  ' 残ったキーは今月にない
        wsOut.Cells(outRow, 1).Resize(1, 2).Value = Array("削除", k)
        outRow = outRow + 1
    Next k
    MsgBox "差分 " & outRow - 2 & " 件を書き出しました"
End Sub

' 比較用に値を文字列にそろえる（エラー値や前後の空白に対応）
Private Function ToText(ByVal v As Variant) As String
    If IsError(v) Then
        ToText = "#ERROR"
    Else
        ToText = Trim(CStr(v))
    End If
End Function

コードのポイント

値の比較は ToText 関数で文字列にそろえてから行っています。セルの値をそのまま比べると、片方が数値の 100、もう片方が文字列の「100」の場合に別の値と判定されて「変更」になったり、セルに #N/A などのエラー値が入っていると「型が一致しません」のエラーで止まったりするためです。前後の空白も取り除いているので、余計な空白だけの違いは変更として扱いません。

キーの重複がある場合は、先月側は最初に出てきた行だけを登録しています。マスタでキーが重複していること自体が問題であることが多いので、事前に重複を確認しておくと判定結果を信頼しやすくなります。

注意点

比較するのは、2つのシートの列の並びが同じであることが前提です。今月から列が追加された場合などは、列の対応がずれて大量の「変更」が出るため、先に見出しが一致しているかを確認してください。

日付の列は、セルの表示形式ではなく内部の値で比べるため、同じ日付でも片方に時刻が含まれていると変更として検出されます。また、変更の色付けはセルを1つずつ塗るため、変更が数千件ある場合は少し時間がかかります。元のシートの色を残したい場合は、今月のシートをコピーしてから実行すると安全です。

• キーとなる列は一意であること
• 列の並びが同じであること
• 色付けの前に元のシートを残しておく

ほかの記事