使用 VBA 在 Excel 电子表格中记录更改

Question

我有以下问题。我需要在电子表格中记录更改。我的范围从 A1:M300000 开始。

到目前为止，我已经成功记录了更改的单元格的地址、用户、旧值和新值。

现在我想插入以下函数并需要帮助。第一次接触VBA：

我还希望我的日志文件显示另一列中单元格的值。所以我知道它是什么。示例更改单元格 B26，现在 A26 也应显示在日志文件中。

此外，我还想记录何时插入新单元格或删除现有记录。

这是我的VBA代码：

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

我希望有人能帮助我。提前非常感谢您。

问候语

钢铁侠

Answer 1

请尝试下一个代码，我昨天为其他提出类似问题的人准备的。它只需要一个事件，并且应该满足您的要求：

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

Answer 2

这是我迄今为止尝试扩展@FaneDuru 代码的尝试。我希望根据问题的原始范围更新更改日志表，但我也希望返回的数组包含偏移量 0,-2 的目标单元格的值。下面的代码对单个单元格数据输入/更改执行此操作，但如果将多个单元格粘贴到命名范围“WENAMES”中，则不会执行此操作。数组的所有其他方面都适用于多单元格数据输入的情况，只是没有偏移量要求

Dim RangeValues As Variant, E As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
 Dim sh As Worksheet: Set sh = Worksheets("Change Log")
 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", "Role", "From", "To", "Sheet Name")

 Application.ScreenUpdating = False                                     'to optimize the code (make it faster)
 Application.Calculation = xlCalculationManual
 If Intersect(Target, Range("WENAMES")) Is Nothing Then Exit Sub
 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 E = 0 To UBound(RangeValues)
    If RangeValues(E)(0) <> TgValue(E)(0) Then
        sh.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).Value = _
                Array(Now, UN, RangeValues(E)(1), Target.Offset(0, -2).Value, RangeValues(E)(0), TgValue(E)(0), Target.Parent.Name)
    End If

 Next E