Macro to track changes to multiple cells

MRSHCL

New Member
Joined
Nov 29, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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.
 
After a bit of tinkering (I must say I am really not sure here), I managed to get the "reason" being recorded for every change tracked by your script.
Here is what the macro does:
-tracks changes (including deletion as does yours)
-prevents multiple cell selection
-prevents execution of keystroke Ctrl+Z and Ctrl+Y which are the only flaw I found so far on the change tracking macro
-requests user for a reason for every change recorded and reports it in the Tracker page
VBA Code:
'Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
Dim Reasonbox As String

Private Sub Workbook_Open()
 Dim StartKeyCombination As Variant
    Dim KeysArray As Variant
    Dim Key As Variant
    Dim I As Long

    On Error Resume Next

    'Shift key = "+"  (plus sign)
    'Ctrl key = "^"   (caret)
    'Alt key = "%"    (percent sign
    'We fill the array with this keys and the key combinations
    'Shift-Ctrl, Shift- Alt, Ctrl-Alt, Shift-Ctrl-Alt

    For Each StartKeyCombination In Array("^")
        'Disable the StartKeyCombination key(s) with every other key
        For I = 121 To 122
            Application.OnKey StartKeyCombination & Chr$(I), ""
        Next I
      

    Next StartKeyCombination
End Sub
Sub Enable_ctrlKeys()
    Dim StartKeyCombination As Variant
    Dim KeysArray As Variant
    Dim Key As Variant
    Dim I As Long

    On Error Resume Next

 
    For Each StartKeyCombination In Array("^")
        'Enable the StartKeyCombination key(s) with every other key
        For I = 121 To 122
            Application.OnKey StartKeyCombination & Chr$(I)
        Next I
        
    Next StartKeyCombination

End Sub
 
'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 - 8 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
Reasonbox = InputBox("Please enter the reason for the change : ", "Reason for change")
    If StrPtr(Reasonbox) = 0 Then
           Debug.Print "Cancel or ESC pressed"
               
        ElseIf Reasonbox = "" Then
           Debug.Print "OK pressed, No value entered, No default value"
               
        Else
            Debug.Print "OK pressed, Value entered or a Default value"
    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 + 8)) = Array("Cell Changed", "Old Value", _
            "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User", "Reason")
            .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, 8) = Reasonbox
            '.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
 
Upvote 0

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
After some macro cleaning and re-testing on a machine other than mine, here is my version of your macro, including
-prevention of multiple cell selection
-prevention of combination Ctrl+Z and Ctrl+Y
-request to user for a reason for every change, record of reason in tracker

VBA Code:
'Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
Dim Reasonbox As String

Private Sub Workbook_Open()
'Joseph Maabo from https://software-solutions-online.com/vba-onkey-method/
        Application.OnKey "^z", ""
        Application.OnKey "^y", ""
End Sub
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
     'MRSHCL & HongRu (https://www.mrexcel.com/board/threads/macro-to-track-changes-to-multiple-cells.1223464/)
     '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")
        tracker.Range("A1:I1").Font.Bold = True
        tracker.Range("A:A").WrapText = True
        tracker.Range("A1:I1").Interior.Color = Gray15
     '**** 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 - 8 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
'lines below trigger a pop-up window prompting user for the reason of the change upon change occurrence and records reason as a string
'https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/msgbox-function
Reasonbox = InputBox("Please enter the reason for the change : ", "Reason for change")
    If StrPtr(Reasonbox) = 0 Then
           Debug.Print "Cancel or ESC pressed"
               
        ElseIf Reasonbox = "" Then
           Debug.Print "OK pressed, No value entered, No default value"
               
        Else
            Debug.Print "OK pressed, Value entered or a Default value"
    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 + 8)) = Array("Cell Changed", "Old Value", _
            "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User", "Reason")
            .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, 8) = Reasonbox
            '.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
 
Upvote 0
this is to be removed
it gives something like this:
VBA Code:
'Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
Dim Reasonbox As String

Private Sub Workbook_Open()
'Joseph Maabo from https://software-solutions-online.com/vba-onkey-method/
        Application.OnKey "^z", ""
        Application.OnKey "^y", ""
End Sub
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
     'MRSHCL & HongRu (https://www.mrexcel.com/board/threads/macro-to-track-changes-to-multiple-cells.1223464/)
     '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.

     '**** 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 - 8 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
'lines below trigger a pop-up window prompting user for the reason of the change upon change occurrence and records reason as a string
'https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/msgbox-function
Reasonbox = InputBox("Please enter the reason for the change : ", "Reason for change")
    If StrPtr(Reasonbox) = 0 Then
           Debug.Print "Cancel or ESC pressed"
               
        ElseIf Reasonbox = "" Then
           Debug.Print "OK pressed, No value entered, No default value"
               
        Else
            Debug.Print "OK pressed, Value entered or a Default value"
    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 + 8)) = Array("Cell Changed", "Old Value", _
            "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User", "Reason")
            .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, 8) = Reasonbox
            '.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
 
Upvote 0
Nicolaw81
Very nice work!
Actually I was searching for same idea and got your code above. I tested it, it was working fine.

I need to request one thing:
Is it possible to link to that particular modified cell?

code like : Range(sOldAddress).Hyperlinks.Add (Mid(Range(sOldAddress), 28, 4))
 
Upvote 0
Nicolaw81
Very nice work!
Actually I was searching for same idea and got your code above. I tested it, it was working fine.

I need to request one thing:
Is it possible to link to that particular modified cell?

code like : Range(sOldAddress).Hyperlinks.Add (Mid(Range(sOldAddress), 28, 4))
Hello Samahiji.
Thank you for the kind words. Yet as mentioned above this is not only my work. I just tried to group it in one file.
I gave a try at turning cell addresses into hyperlinks
The following piece of code were added
VBA Code:
Dim rActiveCell As Range

VBA Code:
 Set rActiveCell = ActiveCell
and
VBA Code:
       .Hyperlinks.Add Anchor:=rActiveCell.Offset(1), Address:=sOldAddress, _
        ScreenTip:="Click to go to " & sOldAddress, _
        TextToDisplay:="Link to " & sOldAddress

So with the code below I could get the hyperlink displayed in "Tracker", but somehow it won't open the actual worksheet and activate the cell in question. I did not even test if a second or a a third change will also display the hyperlink properly in "Tracker". I hope this helps:
VBA Code:
'Option Explicit
Dim sOldAddress As String
Dim rActiveCell As Range
Dim vOldValue As Variant
Dim sOldFormula As String
Dim Reasonbox As String


Private Sub Workbook_Open()
'Joseph Maabo from https://software-solutions-online.com/vba-onkey-method/
        Application.OnKey "^z", ""
        Application.OnKey "^y", ""
End Sub
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
     'MRSHCL & HongRu (https://www.mrexcel.com/board/threads/macro-to-track-changes-to-multiple-cells.1223464/)
     '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.

     '**** 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 - 8 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
'lines below trigger a pop-up window prompting user for the reason of the change upon change occurrence and records reason as a string
'https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/msgbox-function
Reasonbox = InputBox("Please enter the reason for the change : ", "Reason for change")
    If StrPtr(Reasonbox) = 0 Then
           Debug.Print "Cancel or ESC pressed"
               
        ElseIf Reasonbox = "" Then
           Debug.Print "OK pressed, No value entered, No default value"
               
        Else
            Debug.Print "OK pressed, Value entered or a Default value"
    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 + 8)) = Array("Cell Changed", "Old Value", _
            "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User", "Reason")
            .Cells.Columns.AutoFit
        End If
        Set rActiveCell = ActiveCell
        With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)
             
            .Hyperlinks.Add Anchor:=rActiveCell.Offset(1), Address:=sOldAddress, _
        ScreenTip:="Click to go to " & sOldAddress, _
        TextToDisplay:="Link to " & 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, 8) = Reasonbox
            '.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
 
Upvote 0
Hello Nicolaw81
Thanks for your quick response.

I've tested the code above, but it creates a new sheet for hyperlink instead of modifying sheets "Tracker"

The reason why it won't open the actual worksheet is that the subaddress should be in the following format: 'Sheet name'!cell name exactly with single qoute >> ', while the target cell contains file name as well.
 
Upvote 0
OK I don't know how much this helps anyone, but I figured a way to include a request for a username & password at opening of workbook.
The following tabs must be created by default in the workbook:
  • 'Users',
  • 'Passwords',
  • 'Tracker'.
Usernames are stored in column A of "Users" tab, while PW are stored in corresponding cell in column A of "Passwords" tab.
In the future, I'd recommend admin of this file to PW protect these two sheets or hiding them.

I still have a defect to correct (any help welcome) in Tracker when a formula is changed I get a "#VALUE!" warning in the "Old Value" and "New Value" columns of the "Tracker" worksheet 🧐

also, I would like to have each change validated with a PW request prompt, but I am still not sure how to make this happen.
VBA Code:
'Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Dim sOldFormula As String
Dim Reasonbox As String

Private Function IsUserAuthorized() As Boolean
    Dim userSheet As Worksheet
    Dim pwSheet As Worksheet
    Dim userName As String
    Dim userPw As String
    Dim userRange As Range
    Dim pwRange As Range
    
    Set userSheet = ThisWorkbook.Sheets("Users")
    Set pwSheet = ThisWorkbook.Sheets("Passwords")
    
    userName = Application.InputBox("Please enter your username:", "Authentication Required")
    If userName = "" Then Exit Function
    
    Set userRange = userSheet.Range("A:A").Find(What:=userName, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    If userRange Is Nothing Then
        MsgBox "Invalid username", vbCritical
        Exit Function
    End If
    
    userPw = Application.InputBox("Please enter your password:", "Authentication Required", Type:=2)
    If userPw = "" Then Exit Function
    
    Set pwRange = pwSheet.Range("A:A").Find(What:=userPw, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    If pwRange Is Nothing Then
        MsgBox "Incorrect password", vbCritical
        Exit Function
    End If
    
    IsUserAuthorized = True
End Function

Private Sub Workbook_Open()
        Application.OnKey "^z", ""
        Application.OnKey "^y", ""
        
        If Not IsUserAuthorized() Then
        ThisWorkbook.Close savechanges:=False
    End If
       
End Sub
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
     'MRSHCL & HongRu (https://www.mrexcel.com/board/threads/macro-to-track-changes-to-multiple-cells.1223464/)
     '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.

     '**** Add the tracker Sheet if it does not exist ****
     
    If wSheet Is Nothing Then
        Set wActSheet = ActiveSheet
        Worksheets("Tracker").Activate
    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 - 8 '
            If Not .Cells(65536, iCol) = "" Then '
                iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
            End If '
        End If '
'lines below trigger a pop-up window prompting user for the reason of the change upon change occurrence and records reason as a string
'https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/msgbox-function
Reasonbox = InputBox("Please enter the reason for the change : ", "Reason for change")
    If StrPtr(Reasonbox) = 0 Then
           Debug.Print "Cancel or ESC pressed"
               
        ElseIf Reasonbox = "" Then
           Debug.Print "OK pressed, No value entered, No default value"
               
        Else
            Debug.Print "OK pressed, Value entered or a Default value"
    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 + 8)) = Array("Cell Changed", "Old Value", _
            "New Value", "Old Formula", "New Formula", "Time of Change", "Date of Change", "User", "Reason")
            .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, 8) = Reasonbox
            '.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
 
Upvote 0

Forum statistics

Threads
1,223,162
Messages
6,170,432
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top