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

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

Related

Excel VBA - How to remove text of a certain color from every cell in a column

Edit: Now its working much better but the code starts deleting non-black text from other columns as well ?_? the code works for other worksheets so I'm not sure why it only doesn't work for this one... :"( pls help
I have an excel sheet with text that has multiple colors in the same cell e.g. blue and black words in the same cell. I want to remove all the blue words. I wrote a loop that loops through the cells and every character in the cells in the entire column and writes the black words back to each cell. However it takes a really long time so its not very feasible. Also I tried using arrays but I'm not sure how to store the format alongside the value into the array :"( Thanks!
Sub deletecommentsRight_New()
Dim lrow As Long
Dim textOut As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lrow = LastRow()
Range("M1:M" & lrow).Select
For Each Cell In Selection
textOut = ""
For i = 1 To Len(Cell)
If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
textOut = textOut & Mid(Cell, i, 1)
End If
Next
Cell.Value = textOut
Cell.Font.ColorIndex = 1
Next Cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Public Function LastRow() As Long
'Finds the last non-blank cell on a sheet/range.
Dim lrow As Long
Dim lCol As Long
lrow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
LastRow = lrow
End Function
First of all, you should always use Option Explicit at the top of your modules so that it forces you to declare all variables properly.
There is no need to loop through an entire column. Only loop through cells that actually have values. For that we can use the Worksheet.UsedRange property and do an Intersect with the desired range.
Also code should be able to ignore errors and numbers since you are only interested in texts.
Also, there is no need to read the cell value multiple times so best is to read them just once using an array. A With construct can help in reading the cell font colors easily.
Here is what I came up with - kept the original method name:
Option Explicit
Public Sub DeleteComments(ByVal rng As Range)
Dim tempRng As Range
Dim tempArea As Range
Set tempRng = GetUsedRange(rng)
If tempRng Is Nothing Then Exit Sub
'Store app state and turn off some features
Dim scrUpdate As Boolean: scrUpdate = Application.ScreenUpdating
Dim calcMode As XlCalculation: calcMode = Application.Calculation
Dim evEnabled As Boolean: evEnabled = Application.EnableEvents
With Application
If .ScreenUpdating Then .ScreenUpdating = False
If calcMode <> xlCalculationManual Then .Calculation = xlCalculationManual
If .EnableEvents Then .EnableEvents = False
End With
'Loop through all areas. Check/update only relevant values
For Each tempArea In tempRng.Areas
If tempArea.Count = 1 Then
UpdateCell tempArea, tempArea.Value2
Else
Dim arr() As Variant: arr = tempArea.Value2 'Read whole range into array
Dim rowsCount As Long: rowsCount = tempArea.Rows.Count
Dim i As Long: i = 1
Dim j As Long: j = 1
Dim v As Variant
'For Each... loop is faster than using 2 For... Next loops on a 2D array
For Each v In arr 'Column-major order
If VarType(v) = vbString Then 'Only check strings - ignore numbers and errors
If Len(v) > 0 Then UpdateCell tempArea.Cells(i, j), v
End If
i = i + 1
If i > rowsCount Then 'Switch to the next column
j = j + 1
i = 1
End If
Next v
End If
Next tempArea
'Restore app state
With Application
If scrUpdate Then .ScreenUpdating = True
If calcMode <> xlCalculationManual Then .Calculation = calcMode
If evEnabled Then .EnableEvents = True
End With
End Sub
Private Function GetUsedRange(ByVal rng As Range) As Range
If rng Is Nothing Then Exit Function
On Error Resume Next
Set GetUsedRange = Intersect(rng, rng.Worksheet.UsedRange)
On Error GoTo 0
End Function
Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
Dim textOut As String
Dim charExcluded As Boolean
Dim i As Long
For i = 1 To Len(value)
With cell.Characters(i, 1).Font
If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
textOut = textOut & Mid$(value, i, 1)
Else
charExcluded = True
End If
End With
Next i
If charExcluded Then cell.Value2 = textOut
If IsNull(cell.Font.ColorIndex) Then
cell.Font.ColorIndex = 1
ElseIf cell.Font.ColorIndex <> 1 Then
cell.Font.ColorIndex = 1
End If
End Function
As you can see, I've split the code in a few auxiliary functions so that is easier to maintain.
To use it just call it on the desired range. For example:
DeleteComments Selection 'if you already have a selected range
'Or
DeleteComments Range("M:M") 'as in your original post
An added benefit is that this code works regardless if your desired range is a column, a row, multiple columns/rows or even multi-area ranges. Gives you a lot of flexibility and is as fast as you could make it.
Edit #1
The UpdateCell function could be faster if we only check cells with mixed colors:
Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
Dim textOut As String
Dim charExcluded As Boolean
Dim i As Long
If IsNull(cell.Font.ColorIndex) Then
For i = 1 To Len(value)
With cell.Characters(i, 1).Font
If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
textOut = textOut & Mid$(value, i, 1)
Else
charExcluded = True
End If
End With
Next i
If charExcluded Then cell.Value2 = textOut
cell.Font.ColorIndex = 1
ElseIf cell.Font.ColorIndex <> 1 Then
cell.Value2 = Empty
cell.Font.ColorIndex = 1
End If
End Function
You are doing this for over a million cells, most of them are empty. If you start by checking that the cell is not empty, you might heavily improve the performance.
Building on the suggestions provided, here is the modified code. Since the original code worked on selection, an option to ask the user to select a range is opted than defining fixed ranges.
Sub deletecomments()
Dim textOut As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'----------------------------
Dim myrange As Range
ThisWorkbook.Sheets("Sheet1").Activate 'Change Workbook and Sheet name accordingly
Set myrange = Application.InputBox(Title:="Range Selector", Prompt:="Please select your Range.", Type:=8)
'--------------------------
For Each Cell In myrange 'Replace selection with myRange
textOut = ""
For i = 1 To Len(Cell)
If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
textOut = textOut & Mid(Cell, i, 1)
End If
Next
Cell.value = textOut
Cell.Font.ColorIndex = 1
Next Cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

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

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.

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