# Macro to track changes to multiple cells



## MRSHCL (Nov 29, 2022)

I have an Excel macro which is designed to create a new Excel tab ("Tracker") where changes made to any worksheet within the workbook are recorded, detailing "Cell Changed", "Old Value", "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", and "User".

The macro currently will not detail the "Old Value" of the change where the target of the change are multiple cells, and instead shows as "Multiple Cells Selected" in the Tracker tab.

From what I can deduce, I need the declared variable "vOldValue" to equal a string created from the values from the selection, however I don't know how to achieve this.

Please see macro code below:


```
Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
 
Private Sub Workbook_TrackChange(Cancel As Boolean)
     
     
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.PageSetup.LeftFooter = "&06" & ActiveWorkbook.FullName & vbLf & "&A"
    Next sh
End Sub
 
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
     '''''''''''''''''''''''''''''''''''''''''''''
     'lenze 2003(http://vbaexpress.com/kb/getarticle.php?kb_id=909)
     'Colin_L 2009 (http://www.mrexcel.com/forum/showthread.php?t=376400&referrerid=76744)
     'Mark Reierson 2009 (http://www.vbaexpress.com/kb/getarticle.php?kb_id=1074)

     '''''''''''''''''''''''''''''''''''''''''''''
     
    Dim wSheet As Worksheet
    Dim wActSheet As Worksheet
    Dim iCol As Integer
    Set wActSheet = ActiveSheet
     
     'Precursor Exits
     'Other conditions that you do not want to tracke could be added here
    'If vOldValue = "" Then Exit Sub 'If you comment out this line *every* entry will be recorded
     
     'Continue
     
    On Error Resume Next ' This Error-Resume-Next is only to allow the creation of the tracker sheet.
    Set wSheet = Sheets("Tracker")
     '**** Add the tracker Sheet if it does not exist ****
     
    If wSheet Is Nothing Then
        Set wActSheet = ActiveSheet
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Tracker"
    End If
    On Error GoTo 0
     '**** End of specific error resume next
     
    On Error GoTo ErrorHandler
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
     
    With Sheets("Tracker")
         '******** This bit of code moves the tracker over a column when the first columns are full**'
        If .Cells(1, 1) = "" Then '
            iCol = 1 '
        Else '
            iCol = .Cells(1, 256).End(xlToLeft).Column - 7 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
         '********* END *****************************************************************************'
        .Unprotect Password:="Secret"
         
         '******** Sets the Column Headers **********************************************************
        If LenB(.Cells(1, iCol).Value) = 0 Then
            .Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array("Cell Changed", "Old Value", _
            "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User")
            .Cells.Columns.AutoFit
        End If
         
        With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)
             
            .Value = sOldAddress
             
            .Offset(0, 1).Value = vOldValue
            .Offset(0, 3).Value = sOldFormula
             
            If Target.Count = 1 Then
                .Offset(0, 2).Value = Target.Value
                If Target.HasFormula Then .Offset(0, 4).Value = "'" & Target.Formula
            End If
             
            .Offset(0, 5) = Time
            .Offset(0, 6) = Date
            .Offset(0, 7) = Application.UserName
            '.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous 'Adds a line at the end of the row
        End With
         
         '.Protect Password:="Secret"  'Uncomment to protect the "tracker tab"
         
    End With
ErrorExit:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
     
    wActSheet.Activate
    Exit Sub
     
ErrorHandler:
     'any error handling you want
     'Debug.Print "We have an error"
    Resume ErrorExit
     
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
     
    With Target
        sOldAddress = .Address(external:=True)
         
        If .Count > 1 Then
            
            vOldValue = "Multiple Cells Selected" '???? Change this to get value of each cell selected before the change ????
            sOldFormula = vbNullString
             
        Else
             
            vOldValue = .Value
            If .HasFormula Then
                sOldFormula = "'" & Target.Formula
            Else
                sOldFormula = vbNullString
            End If
        End If
    End With
End Sub
```

Any assistance would be greatly appreciated.

Thank you.


----------



## HongRu (Nov 30, 2022)

Try this. HTH

```
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
     
    With Target
        sOldAddress = .Address(external:=True)
        Dim e, i
        If .Count > 1 Then
            For Each e In .Areas
                For Each i In e.Value
                    If vOldValue = "" Then
                        vOldValue = i
                    Else
                        vOldValue = vOldValue & "," & i
                    End If
                Next i
            Next e
            'vOldValue = "Multiple Cells Selected" '???? Change this to get value of each cell selected before the change ????
            sOldFormula = vbNullString
             
        Else
             
            vOldValue = .Value
            If .HasFormula Then
                sOldFormula = "'" & Target.Formula
            Else
                sOldFormula = vbNullString
            End If
        End If
    End With
End Sub
```


----------



## HongRu (Nov 30, 2022)

Add one line to fix a bug of having more then one area.

```
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
    
    With Target
        sOldAddress = .Address(external:=True)
        Dim e, i
        If .Count > 1 Then
            vOldValue = ""      'add this to fix a bug of having more then one area.
            For Each e In .Areas
                For Each i In e.Value
                    If vOldValue = "" Then
                        vOldValue = i
                    Else
                        vOldValue = vOldValue & "," & i
                    End If
                Next i
            Next e
            'vOldValue = "Multiple Cells Selected" '???? Change this to get value of each cell selected before the change ????
            sOldFormula = vbNullString
             
        Else
             
            vOldValue = .Value
            If .HasFormula Then
                sOldFormula = "'" & Target.Formula
            Else
                sOldFormula = vbNullString
            End If
        End If
    End With
End Sub
```


----------



## HongRu (Nov 30, 2022)

The line below should be repalced 


HongRu said:


> For Each i In e.Value


by


HongRu said:


> For Each i In e


----------



## HongRu (Nov 30, 2022)

Your code is really interesting.
So I take a while to work on it.
If you don't mind, try this.

```
'Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
 
'Private Sub Workbook_TrackChange(Cancel As Boolean)
'
'
'    Dim sh As Worksheet
'    For Each sh In ActiveWorkbook.Worksheets
'        sh.PageSetup.LeftFooter = "&06" & ActiveWorkbook.FullName & vbLf & "&A"
'    Next sh
'End Sub
 
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
     '''''''''''''''''''''''''''''''''''''''''''''
     'lenze 2003(http://vbaexpress.com/kb/getarticle.php?kb_id=909)
     'Colin_L 2009 (http://www.mrexcel.com/forum/showthread.php?t=376400&referrerid=76744)
     'Mark Reierson 2009 (http://www.vbaexpress.com/kb/getarticle.php?kb_id=1074)

     '''''''''''''''''''''''''''''''''''''''''''''
    If sh.Name = "Tracker" Then Exit Sub
    Dim wSheet As Worksheet
    Dim wActSheet As Worksheet
    Dim iCol As Integer
    Set wActSheet = ActiveSheet
     
     'Precursor Exits
     'Other conditions that you do not want to tracke could be added here
    'If vOldValue = "" Then Exit Sub 'If you comment out this line *every* entry will be recorded
     
     'Continue
     
    On Error Resume Next ' This Error-Resume-Next is only to allow the creation of the tracker sheet.
    Set wSheet = Sheets("Tracker")
     '**** Add the tracker Sheet if it does not exist ****
     
    If wSheet Is Nothing Then
        Set wActSheet = ActiveSheet
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Tracker"
    End If
    On Error GoTo 0
     '**** End of specific error resume next
     
    On Error GoTo ErrorHandler
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
     
    With Sheets("Tracker")
         '******** This bit of code moves the tracker over a column when the first columns are full**'
        If .Cells(1, 1) = "" Then '
            iCol = 1 '
        Else '
            iCol = .Cells(1, 256).End(xlToLeft).Column - 7 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
         '********* END *****************************************************************************'
        .Unprotect Password:="Secret"
         
         '******** Sets the Column Headers **********************************************************
        If LenB(.Cells(1, iCol).Value) = 0 Then
            .Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array("Cell Changed", "Old Value", _
            "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User")
            .Cells.Columns.AutoFit
        End If
         
        With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)
             
            .Value = sOldAddress
             
            .Offset(0, 1).Value = vOldValue
            .Offset(0, 3).Value = sOldFormula
             sOldFormula = ""
            If Range(sOldAddress).Count = 1 Then
                .Offset(0, 2).Value = Target.Value
                If Target.HasFormula Then .Offset(0, 4).Value = "'" & Target.Formula
            Else
                Dim e, i, tmp
                On Error Resume Next
                    For Each e In Range(sOldAddress).Areas
                        For Each i In e
                            If tmp = "" Then
                                If i = "" Then
                                    tmp = " "
                                    sbHasFormula (i)
                                Else
                                    tmp = i
                                    sbHasFormula (i)
                                End If
                            Else
                                tmp = tmp & "," & i
                                sbHasFormula (i)
                            End If
                        Next i
                    Next e
                tmp = Trim(tmp)
                .Offset(0, 2).Value = tmp
                .Offset(0, 4) = sOldFormula
             End If
             
            .Offset(0, 5) = Time
            .Offset(0, 6) = Date
            .Offset(0, 7) = Application.UserName
            '.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous 'Adds a line at the end of the row
        End With
         
         '.Protect Password:="Secret"  'Uncomment to protect the "tracker tab"
         
    End With
ErrorExit:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
     
    wActSheet.Activate
    Exit Sub
     
ErrorHandler:
     'any error handling you want
     'Debug.Print "We have an error"
    Resume ErrorExit
     
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
    If sh.Name = "Tracker" Then Exit Sub
  
    With Target
        sOldAddress = .Address(external:=True)
        Dim e, i
        If .Count > 1 Then
            vOldValue = ""
            sOldFormula = ""
            On Error Resume Next
            For Each e In .Areas
                For Each i In e
                    If vOldValue = "" Then
                        If i = "" Then
                            vOldValue = " "
                            sbHasFormula (i)
                        Else
                            vOldValue = i
                            sbHasFormula (i)
                        End If
                    Else
                        vOldValue = vOldValue & "," & i
                        sbHasFormula (i)
                    End If
                Next i
            Next e
            vOldValue = Trim(vOldValue)
            'vOldValue = "Multiple Cells Selected" '???? Change this to get value of each cell selected before the change ????
            'sOldFormula = vbNullString
             
        Else
             
            vOldValue = .Value
            If .HasFormula Then
                sOldFormula = "'" & Target.Formula
            Else
                sOldFormula = vbNullString
            End If
        End If
    End With
End Sub

Sub sbHasFormula(ByVal Target As Range)
    If Target.HasFormula Then
        If sOldFormula = "" Then
            sOldFormula = "'" & Target.Formula
        Else
            sOldFormula = sOldFormula & "||" & Target.Formula
        End If
    End If
End Sub
```


----------



## MRSHCL (Nov 30, 2022)

HongRu said:


> Your code is really interesting.
> So I take a while to work on it.
> If you don't mind, try this.
> 
> ...


The code isn't working for me, I'm not sure why. I just copy and pasted it, so it might be formatting issue on my end. Is there something I should be un-commenting?


----------



## HongRu (Nov 30, 2022)

Maybe you can try my excel file directly.
track.xlsm (27.89KB) - SendSpace.com


----------



## MRSHCL (Dec 19, 2022)

I have downloaded the file, however even this is not working for me.

I now suspect the issue is security config on my network (I am not an admin).

I will contact my administrator to see if this is the issue.


----------



## MRSHCL (Dec 19, 2022)

Working now.

It was my network that was preventing the macro running.

Thank you so much!


----------

