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
Bookmarks