excelvba

Excel VBA- Loop Through Target Cells in a Table for Tracking Changes


The following code is in a Worsheet_Change Event Private Sub Worksheet_Change(ByVal Target As Range) and works to track changes to all cells in the active worksheet and record them on a separate sheet 'Change Log'. However, I only want it to track changes in ListObjects(2).

If changes are made in oList2.DataBodyRange.Columns("A:C"), it should intersect oList2.HeaderRowRange. If changes are made in oList2.DataBodyRange.Columns("E:AR"), it should intersect oList1.DataBodyRange.Rows(1).

In addition, every change should be logged in the next row.

I tried changing For Each c In Target to For Each c In ActiveSheet.ListObjects(2).DataBodyRange but then I keep getting run-time error "Method 'Undo' of object'_Application' failed". Debugger takes me to the first Application.Undo.

Private Sub Worksheet_Change(ByVal Target As Range)

   Application.ScreenUpdating = False

    For Each c In Target
        Dim wb As Workbook
        Dim ws2 As Worksheet
        Dim NextRow As Long
        
        Set wb = ThisWorkbook
        Set ws2 = wb.Worksheets("Change Log")
        
        NextRow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
            
        Dim CellAdd As String
        Dim result As String
        Dim oList1 As ListObject
        Dim oList2 As ListObject
        Dim rng As Range
        
        Set oList1 = Me.ListObjects(1)
        Set oList2 = Me.ListObjects(2)
        
        If Not Intersect(c.EntireColumn, oList2.DataBodyRange.Columns("A:C")) Is Nothing Then
            Set rng = Intersect(c.EntireColumn, oList2.HeaderRowRange)
            
            CellAdd = rng.Address
            
        ElseIf Not Intersect(c.EntireColumn, oList2.DataBodyRange.Columns("E:AR")) Is Nothing Then
            Set rng = Intersect(c.EntireColumn, oList1.DataBodyRange.Rows(1))
            
            CellAdd = rng.Address
        End If

        result = Range(CellAdd).Formula

        Dim newValue As String
            newValue = c.Value
        
        Application.EnableEvents = False
        Application.Undo
        oldvalue = c.Value
        Application.Undo
        Application.EnableEvents = True
        
        sheetname = ActiveSheet.Name
            
        If newValue = "" Then
            ws2.Cells(NextRow, 2) = sheetname
            ws2.Cells(NextRow, 3) = result
            ws2.Cells(NextRow, 4) = Environ("username")
            ws2.Cells(NextRow, 5) = Format(Now(), "DD MMMM")
            ws2.Cells(NextRow, 6) = "Was changed to **" & "EMPTY" & _
            "** from **" & oldvalue & "** by " & Environ("username") & " on" & " " & _
            Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
            
        ElseIf oldvalue = 0 Then
            ws2.Cells(NextRow, 2) = sheetname
            ws2.Cells(NextRow, 3) = result
            ws2.Cells(NextRow, 4) = Environ("username")
            ws2.Cells(NextRow, 5) = Format(Now(), "DD MMMM")
            ws2.Cells(NextRow, 6) = "Was changed to **" & newValue & _
            "** from **" & "EMPTY" & "** by " & Environ("username") & " on" & " " & _
            Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
        
        ElseIf oldvalue <> 0 Then
            ws2.Cells(NextRow, 2) = sheetname
            ws2.Cells(NextRow, 3) = result
            ws2.Cells(NextRow, 4) = Environ("username")
            ws2.Cells(NextRow, 5) = Format(Now(), "DD MMMM")
            ws2.Cells(NextRow, 6) = "Was changed to **" & newValue & _
            "** from **" & oldvalue & "** by " & Environ("username") & " on" & " " & _
            Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
        End If
        
        ws2.Columns("B:F").AutoFit
    
    Next c
End Sub

How can I track changes only in ListObjects(2) and why do I keep getting an error?


Solution

  • Option Explicit
    
    Private Sub Worksheet_Change(ByVal Target As Range)
    
        Dim wsLog As Worksheet, 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 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, 1).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).Formula
                    Else
                        sCol = Intersect(c.EntireColumn, Me.ListObjects(1).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, 1) = c.Address
                    .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) = "Was changed to **" & sTo & "** from **" _
                        & sFrom & "** by " & Environ("username") & " on" & " " & _
                        Format(Now(), "DD MMMM, YYYY @ H:MM:ss")
                 
                End If
            Next
            .Columns("B:F").AutoFit
        End With
        
    myerror:
        Application.EnableEvents = True
        If Err.Number Then MsgBox Err.Number & " " & Err.Description
        
    End Sub