excel - 在 Audit Trail 中记录多个单元格的复制粘贴和删除

Question

我找到了一个简单的代码来制作审计跟踪，但它只适用于单个单元格。

如果有人复制粘贴了几个单元格，它就会停止工作。一次删除几个单元格也是如此。

Option Explicit
Dim PreviousValue

Private Sub worksheet_change(ByVal target As Range)
 If target.Value <> PreviousValue Then
 Sheets("LOG").Cells(65000, 22).End(xlUp).Offset(1, 0).Value = Now & " / " & _
  Application.UserName & " / changed cell " & target.Address _
  & "  /from/ " & PreviousValue & " to " & target.Value
 End If
End Sub

Private Sub worksheet_selectionChange(ByVal target As Range)
  PreviousValue = target.Value
End Sub

标签： excelvba

Answer 1

如果您可以接受限制用户可以做什么，那么您可以尝试简单地执行“一次一个单元格”策略：

Private Sub worksheet_change(ByVal target As Range)
    If Target.Cells.Count > 1 Then
        With Application
            .EnableEvents = False ' To stop an infinite loop
            .Undo
            .EnableEvents = True
        End With
        MsgBox "Please change only one cell at a time."
        Exit Sub
    End If
    If target.Value <> PreviousValue Then
        Sheets("LOG").Cells(65000, 22).End(xlUp).Offset(1, 0).Value = Now & " / " & _
        Application.UserName & " / changed cell " & target.Address _
        & "  /from/ " & PreviousValue & " to " & target.Value
    End If
End Sub

编辑

这是适用于范围的版本。只要范围是相同的尺寸：

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, 22).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, 22).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