The following code works to track changes and subsequently list each change in a table.
However, for some reason, I keep getting an error 1004 Method 'Undo' of object '_Application' failed if I select multiple cells and hit delete.
NOTE: This is an extension of Excel VBA- Delete Multiple Cells in a Table for Tracking Changes
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim wsLog As Worksheet
Dim oList1, oList2, chgTbl As ListObject
Dim rng As Range, c As Range, sCol As String
Dim sRowDate, sRowVend, sRowDesc As String
Dim oldValue, sTo As String, sFrom As String
Dim r As Long
On Error GoTo myerror
Application.EnableEvents = False
Set oList1 = Me.ListObjects(1)
Set oList2 = Me.ListObjects(2)
Set rng = Union(oList2.DataBodyRange.Columns("A:C"), _
oList2.DataBodyRange.Columns("E:AR"))
Set wsLog = ThisWorkbook.Sheets("Change Log")
Set chgTbl = wsLog.ListObjects(1)
With chgTbl.Range
Dim rStart As Long, rEnd As Long
r = chgTbl.ListRows.Count
rStart = r + 1
For Each c In Target
If Intersect(c, rng) Is Nothing Then
' do nothing
Else
' column header
If c.Column - oList2.DataBodyRange.Column + 1 <= 3 Then
sCol = Intersect(c.EntireColumn, oList2.HeaderRowRange).Value
Else
sCol = Intersect(c.EntireColumn, oList1.DataBodyRange.Rows(1)).Value
End If
sRowDate = Intersect(c.EntireRow, oList2.ListColumns(1).DataBodyRange).Value
sRowVend = Intersect(c.EntireRow, oList2.ListColumns(2).DataBodyRange).Value
sRowDesc = Intersect(c.EntireRow, oList2.ListColumns(3).DataBodyRange).Value
Application.Undo
oldValue = c
Application.Undo
' so that empty values are easier to read versus just ****
If c.Value = "" Then
sTo = "EMPTY"
sFrom = oldValue
ElseIf oldValue = 0 Then
sTo = c.Value
sFrom = "EMPTY"
ElseIf oldValue <> 0 Then
sTo = c.Value
sFrom = oldValue
End If
' prevent recording when deleting empty cell
If sTo = "EMPTY" And sFrom = "" Then
'do nothing
Else
'log it
Dim NewRow As ListRow
Set NewRow = chgTbl.ListRows.Add
r = 1
With NewRow.Range
.Cells(r, 1) = Environ("username") ' user
.Cells(r, 2) = Format(Now(), "DD MMMM") 'date of Change
.Cells(r, 3) = Me.Name ' month
.Cells(r, 4) = sRowDate ' expense date
.Cells(r, 5) = sRowVend ' vendor
.Cells(r, 6) = sRowDesc ' description
.Cells(r, 7) = sCol ' account (column name)
.Cells(r, 8) = sTo ' new value
.Cells(r, 9) = sFrom ' old value
.Cells(r, 10) = sCol & " was changed to **" & sTo & "** from **" _
& sFrom & "** by " & Environ("username") & " on" & " " & _
Format(Now(), "DD MMMM YYYY @ H:MM:ss")
.Cells(r, 11) = 2
End With
End If
End If
Next
rEnd = r
' change format
For r = rStart To rEnd
If .Cells(r, 11) = 2 Then
.Cells(r, 11).Locked = False
Else
End If
.Cells(r, 11).ClearContents
Next
wsLog.Columns("B:J").AutoFit
End With
myerror:
Application.EnableEvents = True
If Err.Number Then MsgBox Err.Number & " " & Err.Description
End Sub
Furthermore, the changing format is not working. It pastes value of two (2) into .Cells(r, 11) but nothing more.
' change format
For r = rStart To rEnd
If .Cells(r, 11) = 2 Then
.Cells(r, 11).Locked = False
Else
End If
.Cells(r, 11).ClearContents
Next
Made revisions based on comments.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim wsLog As Worksheet
Dim oList1, oList2, chgTbl As ListObject
Dim rng As Range, c As Range, sCol As String
Dim sRowDate, sRowVend, sRowDesc As String
Dim oldValue, sTo As String, sFrom As String
Dim r As Long
Dim dict As Object, k
Set dict = CreateObject("Scripting.Dictionary")
On Error GoTo myerror
Application.EnableEvents = False
Set oList1 = Me.ListObjects(1)
Set oList2 = Me.ListObjects(2)
Set rng = Union(oList2.DataBodyRange.Columns("A:C"), _
oList2.DataBodyRange.Columns("E:AR"))
Set wsLog = ThisWorkbook.Sheets("Change Log")
Set chgTbl = wsLog.ListObjects(1)
With chgTbl.Range
' store changes
For Each c In Target
If Intersect(c, rng) Is Nothing Then
' do nothing
Else
Application.Undo
dict.Add c.Address, c.Value
Application.Undo
End If
Next
' process changes
For Each k In dict
oldValue = dict(k)
Set c = Me.Range(k)
' so that empty values are easier to read versus just ****
If c.Value = "" Then
sTo = "EMPTY"
sFrom = oldValue
ElseIf oldValue = 0 Then
sTo = c.Value
sFrom = "EMPTY"
ElseIf oldValue <> 0 Then
sTo = c.Value
sFrom = oldValue
End If
' prevent recording when deleting empty cell
If sTo = "EMPTY" And sFrom = "" Then
'do nothing
Else
' column header
If c.Column - oList2.DataBodyRange.Column + 1 <= 3 Then
sCol = Intersect(c.EntireColumn, oList2.HeaderRowRange).Value
Else
sCol = Intersect(c.EntireColumn, oList1.DataBodyRange.Rows(1)).Value
End If
sRowDate = Intersect(c.EntireRow, oList2.ListColumns(1).DataBodyRange).Value
sRowVend = Intersect(c.EntireRow, oList2.ListColumns(2).DataBodyRange).Value
sRowDesc = Intersect(c.EntireRow, oList2.ListColumns(3).DataBodyRange).Value
'log it
Dim NewRow As ListRow
Set NewRow = chgTbl.ListRows.Add
With NewRow.Range
.Cells(1, 1) = Environ("username") ' user
.Cells(1, 2) = Format(Now(), "DD MMMM") 'date of Change
.Cells(1, 3) = Me.Name ' month
.Cells(1, 4) = sRowDate ' expense date
.Cells(1, 5) = sRowVend ' vendor
.Cells(1, 6) = sRowDesc ' description
.Cells(1, 7) = sCol ' account (column name)
.Cells(1, 8) = sTo ' new value
.Cells(1, 9) = sFrom ' old value
.Cells(1, 10) = sCol & " was changed to **" & sTo & "** from **" _
& sFrom & "** by " & Environ("username") & " on" & " " & _
Format(Now(), "DD MMMM YYYY @ H:MM:ss")
.Cells(r, 11).Locked = False
End With
End If
Next
wsLog.Columns("B:J").AutoFit
End With
myerror:
Application.EnableEvents = True
If Err.Number Then MsgBox Err.Number & " " & Err.Description
End Sub