跟踪工作表上的更改，复制活动单元格更改 Column Header & NewColumnValue
Track changes on worksheet, copy active cell change Column Header & NewColumnValue
REF: 跟踪工作表上的更改，复制活动单元格行中非活动单元格的单元格并记录值
我修改了我的工作表并希望深入了解如何在更改事件发生时获取单元格中的值...
- NewColumn__Value - 当前 none 正在提取正确的值。活动单元格会影响结果，并希望事前 & post 事件更改后进行比较。我知道它当前的输出与相应的 OldVColumn_Value 相同，但留下来帮助传达问题。
- ColumnHeader - 当前未提取任何值。 header 在'target.value
的第二行
非常感谢任何关于代码整合的想法。我被迫做 'long division' 方法，很高兴看到如何获得 'calculator' 方法，帮助我学习。
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
很高兴从您的评论中了解到您解决了问题。做得好！我确实认为你处理这项任务非常英勇，既不想丢弃我的工作，也不想剥夺你可能获得的好处。请多多关照。
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
由于缺乏数据，我对这段代码做了一些非常有限的测试：它确实创建了一个日志条目，主要是按照您的代码似乎建议的行。一旦您掌握了它，它就会像您自己的一样透明，这让我希望您能够遵循它，例如，插入缺少的员工姓名。添加日期或列非常容易，而且比您拥有的要快得多。评论也不少，应该会有帮助。
关于“旧”值的一个词。我用一个数组替换了你的许多 public 变量，该数组在一行中记录了 all 数据。它在加载（激活）sheet 时以及此后每次单击时执行此操作。如果由于某种原因（这主要发生在测试期间）阵列不可用或错误的阵列可用，用户将被提示重复他的更改。比较水密
REF: 跟踪工作表上的更改，复制活动单元格行中非活动单元格的单元格并记录值
我修改了我的工作表并希望深入了解如何在更改事件发生时获取单元格中的值...
- NewColumn__Value - 当前 none 正在提取正确的值。活动单元格会影响结果，并希望事前 & post 事件更改后进行比较。我知道它当前的输出与相应的 OldVColumn_Value 相同，但留下来帮助传达问题。
- ColumnHeader - 当前未提取任何值。 header 在'target.value 的第二行
非常感谢任何关于代码整合的想法。我被迫做 'long division' 方法，很高兴看到如何获得 'calculator' 方法，帮助我学习。
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
很高兴从您的评论中了解到您解决了问题。做得好！我确实认为你处理这项任务非常英勇，既不想丢弃我的工作，也不想剥夺你可能获得的好处。请多多关照。
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
由于缺乏数据，我对这段代码做了一些非常有限的测试：它确实创建了一个日志条目，主要是按照您的代码似乎建议的行。一旦您掌握了它，它就会像您自己的一样透明，这让我希望您能够遵循它，例如，插入缺少的员工姓名。添加日期或列非常容易，而且比您拥有的要快得多。评论也不少，应该会有帮助。
关于“旧”值的一个词。我用一个数组替换了你的许多 public 变量，该数组在一行中记录了 all 数据。它在加载（激活）sheet 时以及此后每次单击时执行此操作。如果由于某种原因（这主要发生在测试期间）阵列不可用或错误的阵列可用，用户将被提示重复他的更改。比较水密