REF: Track changes on worksheet, copy cell that is not the active cell in active cell row and record value
I have revamped my worksheet and hoping to get insight to how to get values in cells upon change event of...
any thoughts on code consolidation is greatly appreciated. to i'm forced to do 'long division' approach and so great to see how to get to 'calculator' approach, helps me learn.
Option Explicit
Public OldValue, OldColumnJValue, ColumnHeaderX, ColumnJValue, ColumnHeader, OldColumnJJValue,
OldColumnJKValue, OldColumnJLValue, OldColumnJMValue, NewColumnJJValue, NewColumnJKValue,
NewColumnJLValue, NewColumnJMValue, OldColumnMPValue, OldColumnMQValue, OldColumnMRValue,
OldColumnMSValue, NewColumnMPValue, NewColumnMQValue, NewColumnMRValue, NewColumnMSValue,
OldColumnPVValue, OldColumnPWValue, OldColumnPXValue, OldColumnPYValue, NewColumnPVValue,
NewColumnPWValue, NewColumnPXValue, NewColumnPYValue
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
With Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp)
.Offset(1, 0) = ActiveSheet.Name
.Offset(1, 1) = Target.Address(0, 0)
.Offset(1, 2) = Environ("username")
.Offset(1, 3) = Now
'add empl name vlookup formula to this column?
.Offset(1, 5) = ColumnJValue
**.Offset(1, 6) = ColumnHeader**
.Offset(1, 7) = OldValue
.Offset(1, 8) = Target
'2020 pre-change value below
.Offset(1, 9) = OldColumnJJValue
.Offset(1, 10) = OldColumnJKValue
.Offset(1, 11) = OldColumnJLValue
.Offset(1, 12) = OldColumnJMValue
'2020 post-change value below
**.Offset(1, 13) = NewColumnJJValue
.Offset(1, 14) = NewColumnJKValue
.Offset(1, 15) = NewColumnJLValue
.Offset(1, 16) = NewColumnJMValue**
'2021 pre-change value below
.Offset(1, 18) = OldColumnMPValue
.Offset(1, 19) = OldColumnMQValue
.Offset(1, 20) = OldColumnMRValue
.Offset(1, 21) = OldColumnMSValue
'2021 post-change value below
**.Offset(1, 22) = NewColumnMPValue
.Offset(1, 23) = NewColumnMQValue
.Offset(1, 24) = NewColumnMRValue
.Offset(1, 25) = NewColumnMSValue**
'2022 pre-change value below
.Offset(1, 27) = OldColumnPVValue
.Offset(1, 28) = OldColumnPWValue
.Offset(1, 29) = OldColumnPXValue
.Offset(1, 30) = OldColumnPYValue
'2022 post-change value below
**.Offset(1, 31) = NewColumnPVValue
.Offset(1, 32) = NewColumnPWValue
.Offset(1, 33) = NewColumnPXValue
.Offset(1, 34) = NewColumnPYValue**
End With
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Cells.Count = 1 Then
OldValue = Target
'Program name changed
ColumnJValue = Range("A1")(Target.Row, 10)
'Column header of changed cell
**ColumnHeader = Range("A1")(Target.Row, (2, 0)**
'2020 pre-change value below
OldColumnJJValue = Range("A1")(Target.Row, 270)
OldColumnJKValue = Range("A1")(Target.Row, 271)
OldColumnJLValue = Range("A1")(Target.Row, 272)
OldColumnJMValue = Range("A1")(Target.Row, 273)
'2020 post-change value below
**NewColumnJJValue = Range("A1")(Target.Row, 270)
NewColumnJKValue = Range("A1")(Target.Row, 271)
NewColumnJLValue = Range("A1")(Target.Row, 272)
NewColumnJMValue = Range("A1")(Target.Row, 273)**
'2021 pre-change value below
OldColumnMPValue = Range("A1")(Target.Row, 354)
OldColumnMQValue = Range("A1")(Target.Row, 355)
OldColumnMRValue = Range("A1")(Target.Row, 356)
OldColumnMSValue = Range("A1")(Target.Row, 357)
'2021 post-change value below
**NewColumnMPValue = Range("A1")(Target.Row, 354)
NewColumnMQValue = Range("A1")(Target.Row, 355)
NewColumnMRValue = Range("A1")(Target.Row, 356)
NewColumnMSValue = Range("A1")(Target.Row, 367)**
'2022 pre-change value below
OldColumnPVValue = Range("A1")(Target.Row, 438)
OldColumnPWValue = Range("A1")(Target.Row, 439)
OldColumnPXValue = Range("A1")(Target.Row, 440)
OldColumnPYValue = Range("A1")(Target.Row, 441)
'2022 post-change value below
**NewColumnPVValue = Range("A1")(Target.Row, 438)
NewColumnPWValue = Range("A1")(Target.Row, 439)
NewColumnPXValue = Range("A1")(Target.Row, 440)
NewColumnPYValue = Range("A1")(Target.Row, 441)**
Exit Sub
End If
MsgBox "Multiple cell selections are not allowed on this sheet", vbCritical
ActiveCell.Select
End Sub
I'm glad to learn from your comment that you solved your problem. Well done! I did think your tackling the task quite heroic and don't wish to either throw away my work, nor deprive you of its possible benefits. Please take gander.
Option Explicit
Private PrevVal(1) As Variant ' previously selected row data
' PrevVal(0) = row number, PrevVal(1) = row's data
Enum Nws ' data tab (ActiveSheet)
' 147
NwsHeaderRow = 2 ' change to suit (data start immediately below this row)
NwsClmJ = 10 ' Debug.Print Columns("J").Column
NwsClmJJ = 270
NwsClmJK ' no assigned value means preceding + 1
NwsClmJL
NwsClmJM
NwsClmMP = 354
NwsClmMQ
NwsClmMR
NwsClmMS
NwsClmPV = 438
NwsClmPW
NwsClmPX
NwsClmPY
NwsTop ' defining the last used column
End Enum
Private Sub Worksheet_Activate()
' 147
SetPrevVal ActiveCell.Row
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' 147
SetPrevVal Target.Row
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' 147
Dim TriggerRange As Range ' range of relevant changes
Dim MsgTxt() As String ' error message
Dim Log(1 To 34) As Variant ' Log entry
Dim Employee As String ' employee's name (retrieved by VLOOKUP)
Dim i As Long ' index of Log()
Set TriggerRange = Range(Cells(NwsHeaderRow + 1, 1), _
Cells(Rows.Count, "A").End(xlUp)) _
.Resize(, NwsTop - 1)
Debug.Print TriggerRange.Address
With Target
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
If .Cells.CountLarge > 1 Then
MsgTxt = Split("Please change only one cell at a time on this sheet." & _
"|Unsupported user action", "|")
Else
If IsEmpty(PrevVal) Then
MsgTxt = Split("?")
ElseIf PrevVal(0) <> .Row Then
MsgTxt = Split("?")
End If
If Join(MsgTxt) = "?" Then
MsgTxt = Split("Sorry, I lost the previous record." & vbCr & _
"Please repeat the action." & _
"|Internal error", "|")
End If
End If
If Len(Join(MsgTxt)) Then
MsgBox MsgTxt(0), vbCritical, MsgTxt(1)
Application.Undo
.Select
Exit Sub
End If
Employee = "" ' add empl name vlookup formula here
For i = 1 To 8
Log(i) = Array(Environ("username"), Employee, Now, _
ActiveSheet.Name, Cells(.Row, NwsClmJ).Value, _
.Address(0, 0), PrevVal(1)(1, .Column), _
.Value)(i - 1)
Next i
For i = 9 To 12
Log(i) = PrevVal(1)(1, NwsClmJJ + i - 9)
Log(i + 4) = Cells(.Row, NwsClmJJ + i - 9).Value
Next i
' column 17 remains blank by your design
For i = 18 To 21
Log(i) = PrevVal(1)(1, NwsClmMP + i - 18)
Log(i + 4) = Cells(.Row, NwsClmMP + i - 18).Value
Next i
' column 26 remains blank by your design
For i = 27 To 30
Log(i) = PrevVal(1)(1, NwsClmPV + i - 27)
Log(i + 4) = Cells(.Row, NwsClmPV + i - 27).Value
Next i
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With Worksheets("Log")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1) _
.Resize(1, UBound(Log)).Value = Log
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End With
End Sub
Private Function SetPrevVal(ByVal R As Long) As Range
' 147
Dim Rl As Long ' last used row in column [270]
' presuming that column 1 offers a relevant measurement
Rl = Cells(Rows.Count, 1).End(xlUp).Row
' don't record if the selection is in or above the caption row (NwsHeaderRow)
' or below the data range as defined by the end of 'FirstCl'
' you might add an exception for columns < `NwsClmJJ` ??
If (R > NwsHeaderRow) And (R <= Rl) Then
PrevVal(0) = R
' presuming that there is a header for every column in Header Row
PrevVal(1) = DataRange(R).Value
End If
End Function
Private Function DataRange(ByVal R As Long) As Range
' 147
' presuming that there is a header for every column in the Header Row
Set DataRange = Range(Cells(R, 1), Cells(NwsHeaderRow, Columns.Count).End(xlToLeft) _
.Offset(R - NwsHeaderRow))
End Function
For lack of data, I did some very limited testing on this code: It does create a log entry, largely along the lines your code appears to suggest. Once you get the hang of it it's as transparent as your own, which gives me hope that you will be able to follow it and, for example, insert the missing Employee Name. It's very easy to add date or columns, and it's much faster than what you had. There are quite a few comments too, which should prove helpful.
One word about the "old" values. I replaced your many public variables with a single array which records all data in one row. It does so when the sheet is loaded (activated) and thereafter on every click. If, by whatever reason (which mostly happen during testing) the array isn't available or the wrong array is available the user will be prompted to repeat his change. It's rather watertight.