Hello,

I'm not sure if its possible or not, im trying to built an audit trail for excel, however, as far as I have researched it seems you can only do it for one cell at a time, so im wondering if there is a way to get the value when multiple cells are changed and record them one by one.

I have put a detection message when multiple cells are select perhaps thats the only thing to do, if so is there any way to keep the PreviousValue instead of deleting them when multiple cells are selected.

This is the code i have managed to get so far. Im no expert in VBA, just putting things together, and trying to make sense of what i find online and the basic principle.

Also I was hoping perhaps someone can guide me how to add more error checks, making it less prone to fail.

Thank you in advance.


Option Explicit 
Dim PreviousValue 
Dim NR As Long 
Dim ReasonInput As String 
Dim x As Long 
 
 
 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    PreviousValue = Target.Value 
End Sub 
 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
    If Intersect(Target, Range("A:BA")) Is Nothing Then Exit Sub 
    If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then 
        MsgBox ("Multiple Selection Detected." & vbNewLine & " Please delete the initial value and modify one cell at a time.") 
        With Sheets("AuditTrail") 
            NR = .Range("B" & Rows.Count).End(xlUp).Row + 1 
            .Range("B" & NR).Value = Now 
            .Range("C" & NR).Value = Environ("username") 
            .Range("D" & NR).Value = ActiveSheet.Name 
            .Range("G" & NR).Value = Environ("Username") + " has select multiple cells. Value could not be determined" 
            .Range("I" & NR).Value = Target.Address(False, False) 
            Application.EnableEvents = True 
        End With 
        Exit Sub 
    End If 
     
    With Sheets("AuditTrail") 
         
        ReasonInput = InputBox(Prompt:="Cell will be updated with " & vbNewLine & Target.Value & vbNewLine & "Please enter a reason to proceed." & vbNewLine & "A reason must be added to proceed", Title:="Reason") 
        If ReasonInput = vbNullString Then 
            Application.EnableEvents = False 
            If PreviousValue = "" Or Target.Value <> PreviousValue Then 
                Target.Value = "" 
                Range(Target.Address).Value = PreviousValue 
                Application.EnableEvents = True 
                Goto Out 
            Else 
                Target.Value = PreviousValue 
                Application.EnableEvents = True 
                Goto Out 
            End If 
        End If 
         
         
        Application.EnableEvents = False 
         
         
         
        NR = .Range("C" & Rows.Count).End(xlUp).Row + 1 
        .Range("B" & NR).Value = Now 
        .Range("C" & NR).Value = Environ("username") 
        .Range("D" & NR).Value = ActiveSheet.Name 
        .Range("E" & NR).Value = Range("E" & Split(Range(Target.Address).Address(1, 0), "$")(1)).Value 
        .Range("F" & NR).Value = Range(Split(Range(Target.Address).Address(1, 0), "$")(0) & "1").Value 
        .Range("G" & NR).Value = ReasonInput 
        .Range("H" & NR).Value = Target.Address(False, False) 
        .Range("I" & NR).Value = PreviousValue 
        .Range("J" & NR).Value = Target.Value 
        On Error Resume Next 
         
         
    End With 
     
Out: 
    Application.EnableEvents = True 
End Sub