VBA。Excelファイルの差分比較サンプル

課題

比較するExcelの列、列名が増えたり、列名更新されたらプログラム修正必要。
外部の設定ファイルから旧と新の比較する情報(キー、列、列名)を習得して比較するできるようにする必要がある

画面

VBAのコード

Option Explicit
Const SHEET_RESULT As String = "差分結果"

'********************************************
'差分抽出実行ボタン押下
'********************************************
Sub RunDiff()
    Dim wbOld As Workbook, wbNew As Workbook
    Dim wsOld As Worksheet, wsNew As Worksheet, wsRes As Worksheet
    Dim dictOld As Object, dictNew As Object
    Dim fOld As String, fNew As String
    Dim addCnt As Long, delCnt As Long, updCnt As Long

    Application.ScreenUpdating = False
    Application.StatusBar = "ファイル選択チェック中..."

    fOld = ThisWorkbook.path & "\" & Trim(Range("B2").value)
    fNew = ThisWorkbook.path & "\" & Trim(Range("B3").value)

    If fOld = "" Or fNew = "" Then GoTo FINALLY
    If fOld = fNew Then
        MsgBox "同一ファイルは指定できません", vbCritical
        GoTo FINALLY
    End If

    Application.StatusBar = "ファイル読込中..."
    Set wbOld = Workbooks.Open(fOld, ReadOnly:=True)
    Set wbNew = Workbooks.Open(fNew, ReadOnly:=True)

    Set wsOld = wbOld.Sheets(1)
    Set wsNew = wbNew.Sheets(1)
    Set wsRes = PrepareResultSheet()
    
    Set dictOld = LoadData(wsOld)
    Set dictNew = LoadData(wsNew)

    Application.StatusBar = "差分比較中..."
    CompareData dictOld, dictNew, wsRes, addCnt, delCnt, updCnt

    wsRes.Range("H2").value = "追加:" & addCnt
    wsRes.Range("H3").value = "削除:" & delCnt
    wsRes.Range("H4").value = "更新:" & updCnt

    wbOld.Close False
    wbNew.Close False

FINALLY:
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub

'********************************************
'差分結果シート取得
'
'シート名: 差分結果
'
'存在チェック

'   あれば

'       内容クリアのみ (シート削除しない)

'   なければ

'       新規追加
'
'見出し行は必ず再作成
'********************************************
Function PrepareResultSheet() As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(SHEET_RESULT)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.ADD
        ws.Name = SHEET_RESULT
    Else
        ws.Cells.Clear
    End If
    ws.Range("A1:E1").value = Array("区分", "ID", "項目", "旧値", "新値")
    Set PrepareResultSheet = ws
End Function

'********************************************
'IF データ読込
'********************************************
Function LoadData(ws As Worksheet) As Object
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim r As Long, c As Long, lastR As Long, lastC As Long
    lastR = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
    lastC = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For r = 2 To lastR
        Dim key As String: key = ws.Cells(r, 1).value
        If key <> "" Then
            Dim arr() As Variant: ReDim arr(1 To lastC)
            For c = 1 To lastC
                arr(c) = ws.Cells(r, c).value
            Next
            dict(key) = arr
        End If
    Next
    Set LoadData = dict
End Function

'********************************************
'結果出力＋色分け
'********************************************
Sub CompareData(dOld As Object, dNew As Object, ws As Worksheet, _
                ByRef addCnt As Long, ByRef delCnt As Long, ByRef updCnt As Long)
    Dim r As Long: r = 2
    Dim k As Variant, i As Long

    ' --- 削除 ---
    For Each k In dOld.Keys
        If Not dNew.Exists(k) Then
            ws.Cells(r, 1).value = "削除"
            ws.Cells(r, 2).value = k
            ws.Rows(r).Interior.Color = RGB(255, 200, 200)  '赤色
            r = r + 1: delCnt = delCnt + 1
        End If
    Next

    Dim headers As Variant
    headers = Array("IID", "ID名", "URL", "メソッド", "備考")
    
    ' --- 追加 / 更新 ---
    For Each k In dNew.Keys
        If Not dOld.Exists(k) Then
            ws.Cells(r, 1).value = "追加"   '緑色
            ws.Cells(r, 2).value = k
            ws.Rows(r).Interior.Color = RGB(200, 255, 200)
            r = r + 1: addCnt = addCnt + 1
        Else
            For i = 1 To UBound(dNew(k))
                If dNew(k)(i) <> dOld(k)(i) Then
                    ws.Cells(r, 1).value = "更新"
                    ws.Cells(r, 2).value = k
                    ws.Cells(r, 3).value = headers(i - 1)
                    ws.Cells(r, 4).value = dOld(k)(i)
                    ws.Cells(r, 5).value = dNew(k)(i)
                    ws.Rows(r).Interior.Color = RGB(255, 255, 150)  '黄色
                    r = r + 1: updCnt = updCnt + 1
                End If
            Next
        End If
    Next
End Sub

比較するファイル

旧一覧

新一覧

ボタン押下後の差分抽出シート

セルは幅はシート表示後に手動で調整しました