Target cells not triggered by event `Worksheet_Change`. How to fix? - excel

I am using below codes as the following:
Code(1)# Worksheet_SelectionChange Insert Date by using Date Picker(calendar) on sheet "North"
Column M.
Code(2) # Worksheet_Change of sheet North to Log changes of any cells and put in sheet("Log").
Code(3) in a separate module "Calendar" to initiate calendar
the codes works except in one condition
Target cells not triggered by event Worksheet_Change
to produce issue use calendar to enter any value but not click outside Column M then delete these values again , then switch to sheet "Log" you will notice that there are no entries for deleted values at all.
As always: any help will be appreciated.
(Link for the real file found in first comment)
Option Explicit
Option Compare Text
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Not Intersect(Target, Range("M3:M100")) Is Nothing Then
Call Basic_Calendar
Else
boolDate = False 'make it false to trigger the previous behavior in Worksheet_Change event
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) 'Log Changes of Current Sheet and put in Sheet("Log")
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 Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub 'not doing anything if a cell in AK:XFD is changed
Application.ScreenUpdating = False
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 'Avoide trigger the change event after UnDo
If boolDate Then '____________________________________________________________
Dim prevTarget
prevTarget = Target.value 'memorize the target value
Target.value = PrevVal 'change the target value to the one before changing
RangeValues = ExtractData(Target) 'extract data exactly as before
Target.value = prevTarget 'set the last date
Else '____________________________________________________________
Application.Undo
RangeValues = ExtractData(Target) 'Define RangeValue
PutDataBack TgValue, ActiveSheet 'Put back the changed data
End If
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("B" & Range(RangeValues(r)(1)).Row).value
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
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
' in a separate module "Calendar" to initiate calendar
Option Explicit
Option Compare Text
Public PrevVal As Variant, boolDate As Boolean
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
PrevVal = Selection.value: boolDate = True
Selection.value = datevariable
End If
End Sub

In order to make the solution allowing multiple cells entry from the Callendar, but also allowing multiple deletions, please adapt it in the next way:
Use this modified code in the module where Basic_Calendar Sub exists:
Option Explicit
Option Compare Text
Public PrevVal(), boolDate As Boolean
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
PrevVal = Selection.value: boolDate = True
Selection.value = datevariable
Else
Erase PrevVal 'to identify the case of deletion
End If
End Sub
Edited:
If your installation/version is not deal with directly loading the array, please use the next version, which do it by iteration:
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
Dim i As Long
ReDim PrevVal(1 To Selection.Rows.Count, 1 To 1)
For i = 1 To Selection.Rows.Count
PrevVal(i, 1) = Selection.Cells(i).value
Next i
boolDate = True
Selection.value = datevariable
Else
Erase PrevVal 'to identify the case of deletion
End If
End Sub
Adapt this part of the Worksheet_Change event code in the next way:
If Target.Cells.Count > 1 Then
If Not CBool(Not Not PrevVal) Then boolDate = False 'the new line checking if the multiple rows array is empty (or not)
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
The logic of the modification works as following:
a. When the Calendar form is called and it returns a Date, in a multi rows range, the delivered datevariable is dropped in the selected cells, and their previous value are loaded in PrevVal() array;
b. A change in Column "M:M" triggers the event and in case of PrevVal() not empty, it acts as usually for inserting Data (using the PrevVal() array elements instead of UnDo, which does not work for data added by code). In case of an empty array, it makes boolDate = False, switching the code to the clasic variant (able to use UnDo, because deletion has been done by the user)...
No need to check the code on another PC. It was a matter of solution logic starting from a wrong assumption and it cannot work differently than on your laptop.

Related

Log changes (for specific column and giveback of a specific column)

I am hardly familiar with vba but now need an excel whose changes should be logged. I have now found the following code on stack, but still need two adjustments that I can not manage myself. I only need the monitoring of the column K (K2:K2000), if it changes something there that only that is logged. And if I always need the content of column A, for example if she changes something in column K33 then I want the value A33 as the seventh display in my log.
I tried to understand the code, but I couldn't do it myself.I found the following code on stack overflow:
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 = Worksheets("Protokoll")
Dim UN As String: UN = Application.userName
'sh.Unprotect "" 'it should be good to protect the sheet
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
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 columnHeader As String, rowHeader As String
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 '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

Private sub update date automatically when value in a cell changes

Im trying to automatically update current date in cell T when text in cell Q is "won" and a value in cell AM is > 0. I tried the code below and it is working if first the value in cell is > 0 and then you update the text in cell Q BUT if you do it in another way (first update cell Q and secondly the value in cell AM) the date doesn't appear in cell T.
Any idea, what Im I missing?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [Q:Q]) Is Nothing Then
If UCase(Target) = UCase("won") And Target.Offset(, 22) > 0 Then
Target.Offset(, 2) = Int(Now())
End If
End If
End sub
Your code only checks for changes in Q therefore the update does not take place if you change AM first.
My solution has three parts:
use constants for the columns - in case there are changes to the sheet layout you only have to make adjustments here
worksheet_change: only check if one of the columns is affected then call the according sub - by that the reader of the code immediately understands what is going on here
the main routine that inserts the date if condition is met or removes the date if not (maybe you want to adjust this)
Option explicit
Private Const colStatus As String = "Q"
Private Const colValue As String = "AM"
Private Const colDateWon As String = "S"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Set c = Target.Cells(1, 1)
If c.Column = Me.Columns(colStatus).Column Or c.Column = Me.Columns(colValue).Column Then
updateDateWon c.row
End If
End Sub
Private Sub updateDateWon(row As Long)
'--> adjust the name of the sub to your needs
Dim valueToInsert As Variant
With Me
If .Range(colStatus & row) = "won" And .Range(colValue & row) > 0 Then
valueToInsert = Int(Now)
Else
'reset the date in case conditions are not met
valueToInsert = vbNullString
End If
Application.EnableEvents = False 'disable events so that change-event isn't called twice
.Range(colDateWon & row) = valueToInsert
Application.EnableEvents = True
End With
End Sub
A Worksheet Change Applied to Two Non-Adjacent Columns
You need to monitor columns Q and AM for changes.
You need to account for Target being multiple adjacent and non-adjacent cells.
You need to disable events when writing to the worksheet containing this code to not retrigger this event (or trigger any other events).
It is good practice to ensure the re-enabling of events (by using error-handling).
You can combine the cells to be written to (dCell) into a range (drg) and write the stamp in one go.
Int(Now()) or Int(Now) is actually Date.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Const sColsAddress As String = "Q:Q,AM:AM"
Const dCol As String = "T"
Const fRow As Long = 2 ' (e.g. 2 for excluding headers in the first row)
Const sCriteria As String = "won"
Dim srg As Range
With Range(sColsAddress)
Set srg = Intersect(.Cells, Rows(fRow).Resize(Rows.Count - fRow + 1))
End With
Dim sirg As Range: Set sirg = Intersect(srg, Target)
If sirg Is Nothing Then Exit Sub
Dim sirg1 As Range: Set sirg1 = Intersect(sirg.EntireRow, srg.Areas(1))
Dim siCol2 As Long: siCol2 = srg.Areas(2).Column
'Dim dirg As Range: Set dirg = sirg1.EntireRow.Columns(dCol) ' not used
Dim siCell1 As Range
Dim siValue2 As Variant
Dim drg As Range
For Each siCell1 In sirg1.Cells
If StrComp(CStr(siCell1.Value), sCriteria, vbTextCompare) = 0 Then
siValue2 = siCell1.EntireRow.Columns(siCol2).Value
If IsNumeric(siValue2) Then
If siValue2 > 0 Then
If drg Is Nothing Then
Set drg = siCell1.EntireRow.Columns(dCol)
Else
Set drg = Union(drg, siCell1.EntireRow.Columns(dCol))
End If
End If
End If
End If
Next siCell1
If Not drg Is Nothing Then
' Prevent retriggering the event when writing to the worksheet.
Application.EnableEvents = False
drg.Value = Now ' only after testing, use 'dDate = Date'
End If
SafeExit:
' Enable events 'at all cost'.
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub

Conflict between two events if Filtermode = False and any cells changed by Fill handle. Error raised (Method 'Undo' of object 'Application' failed)?

I have two codes depend on application events to run.
Code (1) change color of column_A If FilterMode is True on any column of ActiveSheet.
Code (2) Log changes of any cells in ActiveSheet and put in another sheet("Log").
Error raised if : Filtermode = False and any cells changed by fill handle (the small square in the lower-right corner of the selected cell) ,
I got this error
Method 'Undo' of object '_Application' failed
on this line Application.Undo on Code (2).
I tried to use to disable and enable events with code (1) with no luck.
any help will be appreciated.
Option Compare Text
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
'Code (1) change color of column_A If FilterMode is True on any column of active sheet.
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(196, 240, 255)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End Sub
' Code (2) Log Changes of Current Sheet and put in Sheet("Log")
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue
Dim sh As Worksheet: Set sh = Sheets("Log")
Dim UN As String: UN = Environ$("username")
If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub 'not doing anything if a cell in "AK:XFD" is changed
Application.ScreenUpdating = False
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 'Avoide trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'Define RangeValue
putDataBack TgValue, ActiveSheet 'Reinsert 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("B" & Range(RangeValues(r)(1)).Row).value
Sheets("Log").Range("A" & Rows.count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
'Array("User Name", "Date,Time", "Work Order", "Column Label", "New Value", "Old Value")
Range(RangeValues(r)(1)).EntireRow.AutoFit
If Range(RangeValues(r)(1)).RowHeight < 53 Then
Range(RangeValues(r)(1)).RowHeight = 53
End If
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
I figured out the issue, although the error rising with code (2) Worksheet_Change event ,
But actually SelectionChange event on code(1) is the real problem.
Apparently, when I drag down, it is sort of like selecting cells individually and all of them at the same time.
To solve this issue, a condition must be added to event SelectionChange to count the target cells:
If Target.Cells.CountLarge = 1 then
So I just modified the code to look like this in the SelectionChange part and it now works perfectly.
'Code (1)
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Cells.CountLarge = 1 Then
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(255, 0, 0)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End If
End Sub
In the meantime, I learned that Calculate event would be best choice to trapping a change to a filtered list as described on this link
https://www.experts-exchange.com/articles/2773/Trapping-a-change-to-a-filtered-list-with-VBA.html

Log changes in Excel spreadsheet using VBA

I have the following problem. I need to log changes in a spreadsheet. My range goes from A1:M300000.
So far I have managed to log the address of the changed cell, the user, the old value, and the new value.
Now I would like to insert the following functions and need help. It's the first time I come into contact with VBA:
I also want my log file to show the value of a cell in another column. So I know which object it is. Example change cell B26 and now also A26 should be displayed in the log file.
Furthermore, I also want to log when new cells are inserted or existing records are deleted.
Here is my VBA code:
Option Explicit
Dim mvntWert As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim lngLast As Long
Set wks = Worksheets("Protokoll")
lngLast = wks.Range("A65536").End(xlUp).Row + 1
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
With wks
.Range("A" & lngLast).Value = Target.Address(0, 0)
.Range("B" & lngLast).Value = mvntWert
.Range("C" & lngLast).Value = Target.Value
.Range("D" & lngLast).Value = VBA.Environ("Username")
.Range("E" & lngLast).Value = Now
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
mvntWert = Target.Value
End Sub
I hope someone can help me. Thank you very much in advance.
greeting
ironman
Please, try the next code, I prepared yesterday for somebody else asking for a similar issue. It needs only one event and should do what you require here:
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 = Worksheets("Protokoll")
Dim UN As String: UN = Application.userName
'sh.Unprotect "" 'it should be good to protect the sheet
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
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 columnHeader As String, rowHeader As String
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 '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

How to extract ( first cell of row and column ) of modified cells to put in array, excel vba?

The below code Log changes of sheet (depend on Worksheet_Change ) and put on another sheet "Log " onto multiple cells . the code works flawlessly , But I need to adapt it to get vaule of first Cell of row(s) and column(s) to put in this part of code array
for example, if the changed values are E4, D5, I would like to place in the array, the next pieces of information "E1","D1" "A4","A5"
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)
I tried Target.EntireRow.Cells(1) and Target.EntireColumn.Cells(1) but it is not reliable and not works with multi cells . any help will be appreciated.
this the full code:
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
Application.ScreenUpdating = False
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
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
Please, use the next updated code:
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 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 sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 8) = _
Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name", "Row label", "Colum label")
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 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, 8).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
Please, test the code and send some feedback.
If you want to Not allow logging of modifications in column A:A or first two merged rows, please uncomment the lines starting with If Not Intersect(.... It looks strange to me to make the code logging the column/row header which has just been changed. But it is up to you, of course. You should know better what you need accomplishing...
I would suggest you to protect the working sheet, unlock all cells, then lock only A:A column and first two rows. In this way, the user cannot delete the headers which should be used as references in the logging process.
Please, unprotect he LOG_ sheet and delete the headers from the first row.

Resources