Log changes to multiple cells - excel

Question

I found this code on this forum to log changes to multiple cells to a sheet called "LOG". Not sure how it work but it works great. However, the log showed in single cell on the "LOG" sheet. Is there a way to modify the code so information appear in "LOG" sheet in different row such as date/time in row A, user in row B, etc. Also, can I add to the code so that the sheet "LOG" is password protect from user (but still adding log). Here's the code. Thank you for any help.
Dim RangeValues As Variant
Dim lCols As Long, lRows As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UN As String: UN = Application.UserName
If Target.Cells.Count = 1 Then
If Target.Value <> RangeValues Then
Sheets("LOG").Cells(65000, 1).End(xlUp).Offset(1, 0).Value = Now & " / " & UN & " / changed cell " & Target.Address & " /from/ " & RangeValues & " to " & Target.Value
End If
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.Cells(r, c).Value <> RangeValues(r, c) Then
Sheets("LOG").Cells(65000, 1).End(xlUp).Offset(1, 0).Value = Now & " / " & UN & " / changed cell " & Target.Cells(r, c).Address & " /from/ " & RangeValues(r, c) & " to " & Target.Cells(r, c).Value
End If
Next c
Next r
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeValues = Target.Value
lCols = Target.Columns.Count
lRows = Target.Rows.Count
End Sub

Answer 1

Please, test the next updated solution:
Option Explicit
Dim RangeValues As Variant
Dim lCols As Long, lRows As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
sh.Unprotect "1234" 'use here your real password
If Target.cells.Count = 1 Then
If Target.value <> RangeValues Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
End If
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.cells(r, c).value <> RangeValues(r, c) Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
End If
Next c
Next r
sh.Protect "1234"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeValues = Target.value
lCols = Target.Columns.Count
lRows = Target.rows.Count
End Sub
In fact, only Worksheet_Change event has been changed and added Option Explicit on top of the module.
Edited:
Please, use the next code. It uses only an event and no necessary to previously select the range where to copy:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, lCols As Long, lRows As Long
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
sh.Unprotect "1234" 'use here your real password
Dim TgValue 'the array to keep Target values (before UnDo)
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
TgValue = Target.value
Application.EnableEvents = False
Application.Undo
RangeValues = Range(Target.Address).value 'define the RangeValue
lCols = Target.Columns.Count
lRows = Target.rows.Count
Range(Target.Address).value = TgValue 'Put back the Target value (changed using UnDo)
Application.EnableEvents = True
'One cell in the range
If Target.cells.Count = 1 Then
If Target.value <> RangeValues Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
End If
sh.Protect "1234"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.cells(r, c).value <> RangeValues(r, c) Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
End If
Next c
Next r
sh.Protect "1234"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Second edit:
The version able to deal with continuous ranges, but built by consecutively selecting cells:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, lCols As Long, lRows As Long, contRng As Range
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
sh.Unprotect "" 'use here your real password
Dim TgValue 'the array to keep Target values (before UnDo)
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
If Target.cells.Count > 1 Then
TgValue = Range(Target.Address).value
If Not IsArray(TgValue) Then 'if the range is discontinuous and its first area means single cell
Set contRng = ContRange(Target) 'the discontinuous range is transformed in continuous
TgValue = contRng.value 'only now the range value can be (correctly) put in an array
Set Target = contRng 'the target range is also built as continuous
' Debug.Print "Target = " & Target.Address: 'Stop
Else
Set contRng = Target 'for continuous ranges, even made of a single cell
End If
Else
TgValue = Target.value 'put the target range in an array (or as a string for a single cell)
Set contRng = Target 'set contRng (to be used later) as Target
End If
Application.EnableEvents = False 'avoiding to trigger the change event after UnDo
Application.Undo
RangeValues = Range(contRng.Address).value 'define the RangeValue
'If IsArray(RangeValues) Then Debug.Print RangeValues(1, 1): ' Stop
lCols = Target.Columns.Count 'extract the target number of rows and columns:
lRows = Target.rows.Count
Range(Target.Address).value = TgValue 'Put back the Target value (changed using UnDo)
Application.EnableEvents = True
'One cell in the range
If Target.cells.Count = 1 Then
If Target.value <> RangeValues Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
End If
sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
For c = 1 To lCols
If Target.cells(r, c).value <> RangeValues(r, c) Then
sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
End If
Next c
Next r
sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function ContRange(rng As Range) As Range
Dim a As Range, rngCont As Range
For Each a In rng.Areas
If rngCont Is Nothing Then
Set rngCont = a
Else
Set rngCont = Union(rngCont, a)
End If
Next
If Not rngCont Is Nothing Then Set ContRange = rngCont
End Function
The code can be adapted to also handle real discontinue ranges, but it is a little more complicated and no interested in taking such a challenge...
Third edit:
The next version, follow a different logic and is able to log all kind of modifications, even in discontinuous ranges:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
Dim sh As Worksheet: Set sh = Sheets("LOG_")
Dim UN As String: UN = Application.userName
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")
sh.Unprotect "" 'use here your real password
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
If Target.cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'avoiding to trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'define the RangeValue
putDataBack TgValue, ActiveSheet 'put back the changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
sh.cells(rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
End If
Next r
sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.cells.count - 1)
For Each a In rng.Areas
For i = 1 To a.cells.count
arr(count) = Array(a.cells(i).value, a.cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function