The following code works so long as you only delete one cell at a time. If I select multiple cells at hit delete, I get an error 1004 Method 'Undo' of object '_Application' failed.
NOTE: This is an extension of Excel VBA- Loop Through Target Cells in a Table for Tracking Changes
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsLog As Worksheet, oList1 As ListObject, oList2 As ListObject
Dim rng As Range, c As Range, sCol 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")
With wsLog
r = .Cells(.Rows.Count, 2).End(xlUp).Row
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
Application.Undo
oldValue = c
Application.Undo
' so that empty values are easier to read versus **** in .Cells(r, 8)
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 logging changes when deleting empty cell
If sTo = "EMPTY" And sFrom = "" Then
'do nothing
Else
'log it
r = r + 1
.Cells(r, 2) = Me.Name
.Cells(r, 3) = sCol ' column name
.Cells(r, 4) = Environ("username")
.Cells(r, 5) = Format(Now(), "DD MMMM")
If c.Column - oList2.DataBodyRange.Column + 1 <= 1 Then
.Cells(r, 6) = sTo
.Cells(r, 6).NumberFormat = "m/d/yyyy"
Else
.Cells(r, 6) = sTo
.Cells(r, 6).NumberFormat = "$#,##0.00_);($#,##0.00)"
End If
.Cells(r, 7) = sFrom
.Cells(r, 8) = "Was changed to **" & sTo & "** from **" _
& sFrom & "** by " & Environ("username") & " on" & " " & _
Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
End If
End If
Next
.Columns("B:H").AutoFit
End With
myerror:
Application.EnableEvents = True
If Err.Number Then MsgBox Err.Number & " " & Err.Description
End Sub
I discovered the issue is the following part of the code:
If c.Column - oList2.DataBodyRange.Column + 1 <= 1 Then
.Cells(r, 6) = sTo
.Cells(r, 6).NumberFormat = "m/d/yyyy"
Else
.Cells(r, 6) = sTo
.Cells(r, 6).NumberFormat = "$#,##0.00_);($#,##0.00)"
End If
If I remove the If statement then I can delete multiple cells at once.
'log it
r = r + 1
.Cells(r, 2) = Me.Name
.Cells(r, 3) = sCol ' column name
.Cells(r, 4) = Environ("username")
.Cells(r, 5) = Format(Now(), "DD MMMM")
.Cells(r, 6) = sTo
.Cells(r, 7) = sFrom
.Cells(r, 8) = "Was changed to **" & sTo & "** from **" _
& sFrom & "** by " & Environ("username") & " on" & " " & _
Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
The whole reason I want to add this If statement is because the first column in oList2 are dates so if the change occurs in column 1, I want the before/ after changes to be formatted in a date. All other changes should be formatted as currency.
Change the format for cells in column 6 after the For Each c In Target loop.
With wsLog
Dim rStart As Long, rEnd As Long
r = .Cells(.Rows.Count, 2).End(xlUp).Row
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).Formula
Else
sCol = Intersect(c.EntireColumn, oList1.DataBodyRange.Rows(1)).Formula
End If
Application.Undo
oldvalue = c
Application.Undo
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
'log it
r = r + 1
.Cells(r, 2) = Me.Name
.Cells(r, 3) = sCol ' column name
.Cells(r, 4) = Environ("username")
.Cells(r, 5) = Format(Now(), "DD MMMM")
.Cells(r, 6) = sTo
.Cells(r, 7) = sFrom
.Cells(r, 8) = "Was changed to **" & sTo & "** from **" _
& sFrom & "** by " & Environ("username") & " on" & " " & _
Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
.Cells(r, 9) = c.Column - oList2.DataBodyRange.Column + 1
End If
Next
rEnd = r
' change format
For r = rStart To rEnd
If .Cells(r, 9) <= 1 Then
.Cells(r, 6).NumberFormat = "m/d/yyyy"
Else
.Cells(r, 6).NumberFormat = "$#,##0.00_);($#,##0.00)"
End If
.Cells(r, 9).Clear
Next
.Columns("B:F").AutoFit
End With