I've made a change log script that stores changes of every cell. It's working fine when I change value of one cell at the time. I have problem with drag-copy or whatever the event is called. My change log have a columns for values before the change and after the change. I don't have idea how I can fetch previous value during the Drag-Copy (AutoFill) event, because only when you release the mouse button the selection is made but with release new values are already there.
For example, let assume you have in column "A" 4 values
A1=1;
A2=2;
A3=3;
A4=4
If I drag-copy "1" from first cell to the last forth cell. I should see in the log
A2: current value =1 ; previous value = 2;
A3: current value =1 ; previous value = 3;
A4: current value =1 ; previous value = 4;
How to detect the autofill area for Previous Values before AutoFill populates cells with copied values?
Option Explicit
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("Change Log") 'it returns in a sheet named "Change Log"
Dim UN As String: UN = Application.UserName
'If Not Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub 'not doing anything if a cell in A:A is changed
If Not Intersect(ActiveCell, Range("1:3")) Is Nothing Then Exit Sub 'Not doing anything if a cell is changed in first 3 rows
'If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 8) = _
' Array("Date & Time", "User Name", "Changed cell", "From", "To", "Sheet Name", "Column Name")
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
Dim IdRow As String
Dim customer As String
Dim Markup As String
Dim lsp As String
Dim columnHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
columnHeader = Cells(4, Range(RangeValues(r)(1)).Column).Value 'headers are on row 4
lsp = Cells(Range(RangeValues(r)(1)).Row, 5).Value
customer = Cells(Range(RangeValues(r)(1)).Row, 4).Value
' Markup = Cells(Range(RangeValues(r)(1)).Row, 8).Value
IdRow = Cells(Range(RangeValues(r)(1)).Row, 1).Value
sh.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 9).Value = _
Array(Now, IdRow, UN, Range(RangeValues(r)(1)).Row, RangeValues(r)(0), TgValue(r)(0), lsp, _
Target.Parent.Name, columnHeader) ' if you want to see address of the changed cell leavr only RangeValues(r)(1)
End If
Next r
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 'creating a jagged array containing the values and the cells address
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
Please, try the next code. Adapt it for your needs.
Option Explicit
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_") 'it returns in a sheet named "LOG_"
'Please, adapt the code, or name a sheet as necessary for the code to work
Dim UN As String: UN = Application.UserName
'If Not Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub 'not doing anything if a cell in A:A is changed
'If Not Intersect(ActiveCell, Range("1:2")) Is Nothing Then Exit Sub 'Not doing anything if a cell is changed in first two rows
'sh.Unprotect "" 'use here your real password, if any
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
Dim strDelInsert As String
If Target.Columns.count = Me.Columns.count Then
'to make code 'understanding' deletion versus insertion:
strDelInsert = IIf(WorksheetFunction.CountA(Target) > 0, "Delete row(s): ", "Inserted row(s): ")
If Target.rows.count > 1 Then
MsgBox "It deals with only one row insertion/deletion..."
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True: Exit Sub
End If
sh.cells(rows.count, 1).End(xlUp).offset(1, 0).Resize(1, 6).value = _
Array(Now, UN, strDelInsert & Target.address, , , Me.name): Exit Sub
ElseIf 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
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
'columnHeader = cells(1, Range(RangeValues(r)(1)).Column).value
'rowHeader = Range("A" & Range(RangeValues(r)(1)).row).value
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, rowHeader, columnHeader)
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 'creating a jagged array containing the values and the cells address
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