【ExcelVBA・マクロ】2つのシートの差分を自動抽出する方法｜Dictionaryで高速比較するマクロ【コピペOK】

見積書の旧バージョンと新バージョン、更新前後の在庫表など、「2つのシートを見比べて、どこが変わったのかを洗い出したい」という作業は意外と多いものです。目視でのチェックはミスが起きやすく、行数が多いと現実的ではありません。

この記事では、ExcelVBAのDictionaryオブジェクトを使って、2つのシートの差分（追加・削除・変更）を高速に自動抽出するマクロを解説します。

なぜDictionaryを使うと高速なのか

2つのシートを比較する方法として、一方のシートの各行をもう一方のシートの全行と突き合わせる「二重ループ」も考えられますが、この方法はデータ件数が増えるほど処理時間が急激に増加します（データが1000行なら最大100万回の比較が必要になります）。

Dictionaryオブジェクトを使うと、キー（商品コードなど）を指定するだけで該当データの有無を瞬時に判定できるため、データ件数に比例した処理時間で比較が完了します。大量データの差分抽出では、Dictionaryを使うかどうかで処理速度に大きな差が出ます。

事前準備：比較する2つのシートのイメージ

このマクロでは、以下のような構成のシートを比較する前提で解説します。

• 比較対象は「旧データ」シートと「新データ」シートの2つ
• A列に一意のキー（商品コードなど）、B列に比較したい値（金額や在庫数など）が入っている
• 1行目は見出し行

キーとなる列（この例ではA列）にデータが重複なく入力されていることが前提です。同じキーが複数行に存在する場合は、後述の注意点を参照してください。

Dictionaryを使った差分抽出の基本ロジック

処理の流れは大きく3ステップです。

1. 「旧データ」シートの内容をすべてDictionaryに読み込む（キー：A列の値、アイテム：B列の値）
2. 「新データ」シートを1行ずつ確認し、Dictionaryに同じキーがあるかどうかで「追加」「変更」を判定する
3. 比較が終わった時点でDictionaryに残っているキーは、新データ側に存在しない「削除された行」と判定する

① 旧データをDictionaryに読み込む

Dim dictOld As Object
Set dictOld = CreateObject("Scripting.Dictionary")

Dim lastRowOld As Long
lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row

Dim i As Long
For i = 2 To lastRowOld
    Dim keyOld As String
    keyOld = wsOld.Cells(i, "A").Value
    If Not dictOld.Exists(keyOld) Then
        dictOld.Add keyOld, wsOld.Cells(i, "B").Value
    End If
Next i

② 新データと比較しながら「追加」「変更」を判定する

If dictOld.Exists(keyNew) Then
    If dictOld(keyNew) <> valNew Then
        ' 値が異なる場合は「変更」
    End If
    dictOld.Remove keyNew  ' 比較済みのキーは削除しておく
Else
    ' 旧データに存在しないキーは「追加」
End If

比較が終わったキーをRemoveメソッドで取り除いておくのがポイントです。こうすることで、最後にDictionaryに残っているキーだけを見れば「削除された行」を特定できます。

全体のコード

3つのステップをまとめた、差分抽出マクロの全体は以下の通りです。実行すると「差分結果」シートが新しく作成され、「区分（追加・削除・変更）」「キー」「旧データ」「新データ」の一覧が出力されます。

Sub CompareSheets()
    Dim wsOld As Worksheet, wsNew As Worksheet, wsResult As Worksheet
    Set wsOld = ThisWorkbook.Worksheets("旧データ")
    Set wsNew = ThisWorkbook.Worksheets("新データ")

    ' 差分結果シートを作り直す
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("差分結果").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set wsResult = ThisWorkbook.Worksheets.Add(After:=wsNew)
    wsResult.Name = "差分結果"
    wsResult.Range("A1:D1").Value = Array("区分", "キー", "旧データ", "新データ")

    Dim dictOld As Object
    Set dictOld = CreateObject("Scripting.Dictionary")

    Dim lastRowOld As Long
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row

    Dim i As Long
    For i = 2 To lastRowOld
        Dim keyOld As String
        keyOld = wsOld.Cells(i, "A").Value
        If Not dictOld.Exists(keyOld) Then
            dictOld.Add keyOld, wsOld.Cells(i, "B").Value
        End If
    Next i

    Dim lastRowNew As Long
    lastRowNew = wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row

    Dim resultRow As Long
    resultRow = 2

    For i = 2 To lastRowNew
        Dim keyNew As String
        Dim valNew As Variant
        keyNew = wsNew.Cells(i, "A").Value
        valNew = wsNew.Cells(i, "B").Value

        If dictOld.Exists(keyNew) Then
            If dictOld(keyNew) <> valNew Then
                wsResult.Cells(resultRow, 1).Value = "変更"
                wsResult.Cells(resultRow, 2).Value = keyNew
                wsResult.Cells(resultRow, 3).Value = dictOld(keyNew)
                wsResult.Cells(resultRow, 4).Value = valNew
                resultRow = resultRow + 1
            End If
            dictOld.Remove keyNew
        Else
            wsResult.Cells(resultRow, 1).Value = "追加"
            wsResult.Cells(resultRow, 2).Value = keyNew
            wsResult.Cells(resultRow, 3).Value = ""
            wsResult.Cells(resultRow, 4).Value = valNew
            resultRow = resultRow + 1
        End If
    Next i

    ' 比較済みのキーを取り除いた後、Dictionaryに残っているキー＝削除された行
    Dim k As Variant
    For Each k In dictOld.Keys
        wsResult.Cells(resultRow, 1).Value = "削除"
        wsResult.Cells(resultRow, 2).Value = k
        wsResult.Cells(resultRow, 3).Value = dictOld(k)
        wsResult.Cells(resultRow, 4).Value = ""
        resultRow = resultRow + 1
    Next k

    MsgBox "差分抽出が完了しました（" & (resultRow - 2) & "件）", vbInformation
End Sub

使うときの注意点

キーが重複している場合

このマクロは、A列のキーが重複なく一意であることを前提にしています。同じキーが複数行にある場合、dictOld.Addでエラーになるのを避けるためIf Not dictOld.Exists(keyOld) Thenで2件目以降を無視する作りになっていますが、正確な差分を取りたい場合はキー自体を「商品コード＋日付」のように複数列を組み合わせた一意な文字列にすることをおすすめします。

keyOld = wsOld.Cells(i, "A").Value & "_" & wsOld.Cells(i, "C").Value

Dictionaryの参照設定について

上記のコードではCreateObject("Scripting.Dictionary")を使う後期バインディングの方法を採用しているため、事前の参照設定は不要です。処理速度を少しでも上げたい場合は、VBEの「ツール」→「参照設定」から「Microsoft Scripting Runtime」を追加し、Dim dictOld As New Dictionaryのように宣言する前期バインディングも利用できます。Dictionaryの詳しい使い方は、当ブログの別記事「Dictionaryオブジェクト完全ガイド」もあわせてご覧ください。

大文字・小文字を区別したくない場合

Dictionaryは既定でキーの大文字・小文字を区別します。区別したくない場合は、キーをUCase関数などで統一してからAdd・Exists・Removeを実行してください。

まとめ

Dictionaryオブジェクトを使うことで、2つのシートの「追加」「削除」「変更」を高速かつシンプルなコードで抽出できます。二重ループでの突き合わせに比べて処理速度が大きく改善するため、データ件数が多い見積書や在庫表などの比較作業にはぜひ活用してみてください。