excel - 记录对多个单元格的更改

Question

我在这个论坛上找到了这段代码，用于将多个单元格的更改记录到一个名为“LOG”的工作表中。不知道它是如何工作的，但它工作得很好。但是，日志显示在“日志”表上的单个单元格中。有没有办法修改代码，使信息出现在不同行的“LOG”表中，例如 A 行中的日期/时间、B 行中的用户等。另外，我可以添加到代码中以便“LOG”表是用户密码保护（但仍添加日志）。这是代码。感谢您的任何帮助。

Dim RangeValues As Variant
Dim lCols As Long, lRows As Long

Private Sub Worksheet_Change(ByVal Target As Range)
Dim UN As String: UN = Application.UserName
If Target.Cells.Count = 1 Then
    If Target.Value <> RangeValues Then
        Sheets("LOG").Cells(65000, 1).End(xlUp).Offset(1, 0).Value = Now & " / " & UN & " / changed cell " & Target.Address & "  /from/ " & RangeValues & " to " & Target.Value
    End If
    Exit Sub
End If
' More than one cell in the range
Dim r As Long, c As Long
For r = 1 To lRows
    For c = 1 To lCols
        If Target.Cells(r, c).Value <> RangeValues(r, c) Then
            Sheets("LOG").Cells(65000, 1).End(xlUp).Offset(1, 0).Value = Now & " / " & UN & " / changed cell " & Target.Cells(r, c).Address & "  /from/ " & RangeValues(r, c) & " to " & Target.Cells(r, c).Value
        End If
    Next c
Next r
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeValues = Target.Value
lCols = Target.Columns.Count
lRows = Target.Rows.Count
End Sub

标签： excelvbalogging

Answer 1

请测试下一个更新的解决方案：

Option Explicit

Dim RangeValues As Variant
Dim lCols As Long, lRows As Long

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim sh As Worksheet: Set sh = Sheets("LOG_")
 Dim UN As String: UN = Application.userName
 If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
 sh.Unprotect "1234" 'use here your real password
 If Target.cells.Count = 1 Then
    If Target.value <> RangeValues Then
        sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
                 Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
    End If
    Exit Sub
 End If
 ' More than one cell in the range
 Dim r As Long, c As Long
 For r = 1 To lRows
    For c = 1 To lCols
        If Target.cells(r, c).value <> RangeValues(r, c) Then
            sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
                 Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
        End If
    Next c
 Next r
 sh.Protect "1234"
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   RangeValues = Target.value
   lCols = Target.Columns.Count
   lRows = Target.rows.Count
End Sub

实际上，只有Worksheet_Change事件被更改并添加Option Explicit到模块顶部。

编辑：

请使用下一个代码。它仅使用一个事件，无需事先选择要复制的范围：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim RangeValues As Variant, lCols As Long, lRows As Long
 Dim sh As Worksheet: Set sh = Sheets("LOG_")
 Dim UN As String: UN = Application.userName
 If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
 sh.Unprotect "1234" 'use here your real password
 
 Dim TgValue 'the array to keep Target values (before UnDo)
 
 Application.ScreenUpdating = False               'to optimize the code (make it faster)
 Application.Calculation = xlCalculationManual
 
 TgValue = Target.value
 Application.EnableEvents = False
  Application.Undo
  RangeValues = Range(Target.Address).value 'define the RangeValue
  lCols = Target.Columns.Count
  lRows = Target.rows.Count
  Range(Target.Address).value = TgValue 'Put back the Target value (changed using UnDo)
 Application.EnableEvents = True
 
 'One cell in the range
 If Target.cells.Count = 1 Then
    If Target.value <> RangeValues Then
        sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
                 Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
    End If
     sh.Protect "1234"
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
 End If
 ' More than one cell in the range
 Dim r As Long, c As Long
 For r = 1 To lRows
    For c = 1 To lCols
        If Target.cells(r, c).value <> RangeValues(r, c) Then
            sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
                 Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
        End If
    Next c
 Next r
 sh.Protect "1234"
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

第二次编辑：

该版本能够处理连续范围，但通过连续选择单元格构建：

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim RangeValues As Variant, lCols As Long, lRows As Long, contRng As Range
 Dim sh As Worksheet: Set sh = Sheets("LOG_")
 Dim UN As String: UN = Application.userName
 If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 5) = Array("Time", "User Name", "Changed cell", "From", "To")
 sh.Unprotect "" 'use here your real password
 
 Dim TgValue 'the array to keep Target values (before UnDo)
 
 Application.ScreenUpdating = False               'to optimize the code (make it faster)
 Application.Calculation = xlCalculationManual
 
 If Target.cells.Count > 1 Then
    TgValue = Range(Target.Address).value
    If Not IsArray(TgValue) Then            'if the range is discontinuous and its first area means single cell
        Set contRng = ContRange(Target) 'the discontinuous range is transformed in continuous
        TgValue = contRng.value             'only now the range value can be (correctly) put in an array
        Set Target = contRng                  'the target range is also built as continuous
       ' Debug.Print "Target =  " & Target.Address: 'Stop
    Else
       Set contRng = Target                   'for continuous ranges, even made of a single cell
    End If
 Else
    TgValue = Target.value             'put the target range in an array (or as a string for a single cell)
    Set contRng = Target               'set contRng (to be used later) as Target
 End If
 Application.EnableEvents = False                       'avoiding to trigger the change event after UnDo
     Application.Undo
     RangeValues = Range(contRng.Address).value 'define the RangeValue
     'If IsArray(RangeValues) Then Debug.Print RangeValues(1, 1): ' Stop
     lCols = Target.Columns.Count                      'extract the target number of rows and columns:
     lRows = Target.rows.Count
     Range(Target.Address).value = TgValue         'Put back the Target value (changed using UnDo)
 Application.EnableEvents = True
 'One cell in the range
 If Target.cells.Count = 1 Then
    If Target.value <> RangeValues Then
        sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
                 Array(Now, UN, Target.Address(0, 0), RangeValues, Target.value)
    End If
     sh.Protect ""
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
 End If
 ' More than one cell in the range
 Dim r As Long, c As Long
 For r = 1 To lRows
    For c = 1 To lCols
        If Target.cells(r, c).value <> RangeValues(r, c) Then
            sh.cells(rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 5).value = _
                 Array(Now, UN, Target.cells(r, c).Address(0, 0), RangeValues(r, c), Target.cells(r, c).value)
        End If
    Next c
 Next r
 sh.Protect ""
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

Function ContRange(rng As Range) As Range
    Dim a As Range, rngCont As Range
    
    For Each a In rng.Areas
        If rngCont Is Nothing Then
            Set rngCont = a
        Else
           Set rngCont = Union(rngCont, a)
        End If
    Next
    If Not rngCont Is Nothing Then Set ContRange = rngCont
End Function

该代码也可以适应处理真正的中断范围，但它有点复杂，对接受这样的挑战没有兴趣......

第三次编辑：

下一个版本，遵循不同的逻辑，并且能够记录所有类型的修改，即使在不连续的范围内：

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 sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
                                     Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")
 sh.Unprotect "" 'use here your real password

 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

 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
            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