セルの値変更を自動で履歴として記録する方法！ 変更前・変更後の値を保存するVBA | EXCELトピックス

Dim OldValues As Object ' 変更前の値を一時保持する辞書オブジェクト

' 1. セルを選択したとき、変更前の値を辞書に記憶するイベント
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim cell As Range
    
    ' 辞書が未作成の場合のみ生成
    If OldValues Is Nothing Then
        Set OldValues = CreateObject("Scripting.Dictionary")
    End If
    
    ' 選択されたセルのアドレスと値をペアで記憶
    For Each cell In Target
        If Not IsEmpty(cell.Value) Then
            OldValues(cell.Address) = cell.Value
        Else
            OldValues(cell.Address) = "(空白)"
        End If
    Next cell
End Sub

' 2. セルの値が書き換わったとき、変更履歴シートにログを書き出すイベント
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim oldValue As String

    ' 変更履歴シートの有無を確認し、なければ新規作成
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("変更履歴")
    On Error GoTo 0

    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = "変更履歴"
        ' 見出しを設定
        ws.Range("A1:F1").Value = Array("No.", "変更日時", "変更者", "セルアドレス", "変更前の値", "変更後の値")
    End If

    ' 【超重要】履歴書き込みによる不要なイベント連鎖（無限ループ）を防ぐ
    Application.EnableEvents = False
    
    On Error GoTo ErrorHandler

    ' 変更されたセルを1つずつループ処理（複数セルの同時変更・コピペにも対応）
    For Each cell In Target
        ' 変更前の値を取得（辞書になければ空白だったとみなす）
        If Not OldValues Is Nothing Then
            If OldValues.Exists(cell.Address) Then
                oldValue = OldValues(cell.Address)
            Else
                oldValue = "(空白)"
            End If
        Else
            oldValue = "(不明)"
        End If

        ' 履歴シートの最終行の下にデータを書き出す
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
        ws.Cells(lastRow, 1).Value = lastRow - 1
        ws.Cells(lastRow, 2).Value = Now
        ws.Cells(lastRow, 3).Value = Application.UserName
        ws.Cells(lastRow, 4).Value = cell.Parent.Name & "!" & cell.Address(False, False)
        ws.Cells(lastRow, 5).Value = oldValue
        ws.Cells(lastRow, 6).Value = cell.Value
    Next cell

ErrorHandler:
    ' 【超重要】イベント機能を必ず有効に戻す
    Application.EnableEvents = True
End Sub