Question

我为＆＃34; Profile＆＃34;上发生的任何更改创建了审计跟踪。片。在配置文件表上进行的任何更改都记录在另一个工作表中 - ChangeHistory。

但是，我注意到只有在手动更改单元格内容时才会记录更改。不记录来自其他工作表的外部链接发生的更改。

您能帮助并建议对此代码进行任何修改吗？我不是VBA的专家，所以非常感谢你的宝贵帮助。

这是我目前的代码： Profile code

提前致谢

 Dim PreviousValue

Private Sub Worksheet_Change(ByVal Target As Range)
Dim AuditRecord As Range
' This is our change history ...
 Set AuditRecord = Worksheets("ChangeHistory").Range("A4:B65000")
 r = 0
 ' Now find the end of the Change History to start appending to ...
 Do
    r = r + 1
 Loop Until IsEmpty(AuditRecord.Cells(r, 1))
 ' For each cell modified ...
 For Each c In Target
   Value = c.Value
   Row = c.Row
   ' ... update Change History with value and time stamp of modification
   AuditRecord.Cells(r, 1) = Worksheets("Profile").Cells(Row, 4)
   AuditRecord.Cells(r, 2) = Value
   AuditRecord.Cells(r, 3).Value = PreviousValue
   AuditRecord.Cells(r, 5).NumberFormat = "dd mm yyyy    hh:mm:ss"
   AuditRecord.Cells(r, 5).Value = Now
   AuditRecord.Cells(r, 4).Value = Application.UserName

   r = r + 1

 Next

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    PreviousValue = Target.Value
End Sub

Answer 1

可能有更好的方法可以做到这一点，但这就是我想到的：

在个人资料表模块中

Option Explicit
Public dArr As Variant
Private Sub Worksheet_Calculate()
    Dim nArr As Variant
    Dim auditRecord As Range
    Dim i As Long
    Dim j As Long

    nArr = Me.UsedRange

    'Look for changes to the used range
    For i = 1 To UBound(dArr, 2)
        For j = 1 To UBound(dArr, 1)
            If nArr(j, i) <> dArr(j, i) Then
                'write to range
                If Not Write_Change(dArr(j, i), nArr(j, i), Me.Cells(j, i).Address) Then
                    MsgBox "The change was not recorded.", vbInformation
                End If
            End If
        Next j
    Next i

    Erase nArr, dArr
    dArr = Me.UsedRange
End Sub
Private Sub Worksheet_Change(ByVal target As Range)
    Dim Cell As Range
    Dim oldValue As Variant

    For Each Cell In target
        On Error Resume Next
        oldValue = vbNullString
        oldValue = dArr(Cell.Row, Cell.Column)
        On Error GoTo 0
        If oldValue <> Cell.Value Then
            If Not Write_Change(oldValue, Cell.Value, Cell.Address) Then
                MsgBox "The change was not recorded.", vbInformation
            End If
        End If
    Next Cell

    On Error Resume Next
    Erase dArr
    On Error GoTo 0

    dArr = Me.UsedRange
End Sub
Private Sub Worksheet_SelectionChange(ByVal target As Range)
    dArr = Me.UsedRange
End Sub
Public Function Write_Change(oldValue, newValue, cellAddress As String) As Boolean
    Dim auditRecord As Range
    On Error GoTo errHandler
    Set auditRecord = Sheets("ChangeHistory").Range("A:A").Find("*", searchdirection:=xlPrevious).Offset(1, 0)
    With auditRecord
        .Value = cellAddress 'Address of change
        .Offset(0, 1).Value = newValue 'new value
        .Offset(0, 2).Value = oldValue 'previous value
        .Offset(0, 3).NumberFormat = "dd mm yyyy hh:mm:ss"
        .Offset(0, 3).Value = Now 'time of change
        .Offset(0, 4).Value = Application.UserName 'user who made change
        .Offset(0, 5).Value = Me.Range(Split(cellAddress, "$")(1) & 1).Value 'header column value
        .Offset(0, 6).Value = Me.Range("D" & Split(cellAddress, "$")(2)).Value 'header row value
    End With
    Write_Change = True
    Exit Function
errHandler:
    Write_Change = False
    Debug.Print "Error number: " & Err.Number
    Debug.Print "Error descr: " & Err.Description
End Function

在ThisWorkbook模块中

Private Sub Workbook_Open()
    dArr = Sheets("Profile").UsedRange
End Sub

<强>解释

此解决方案的关键是公共阵列dArr。该数组将在内存中保存工作表中的静态值列表，并且只要您使用SelectionChange事件在工作表上进行其他选择，就会更新该数组。

我们使用Calculate事件来处理公式更新单元格内容的时间。为此，我们将新值存储在工作表中的数组nArr中，然后遍历数组并将值与dArr中的静态值进行比较。

将使用Change事件捕获粘贴值或手动添加的值。

要使其正常工作，只要用户打开工作簿，就必须填写dArr。为此，您必须将其添加到Workbook_Open事件中，如上所示。

其他笔记

如前所述here by Tim，有时全局变量可能会通过未处理的错误丢失其值，因此如果您选择使用此解决方案，请确保在此项目中包含良好的错误处理。

这只会写入值更改。使用此方法无法捕获格式更改。

如果“个人资料”表上只有一个值，则无效。如果需要，可以修改为像那样工作。

我在64位excel-2013中对上述代码进行了一些小测试，但您可能希望进行更广泛的测试，以确保通过上述代码捕获所有更改。

当公式或外部链接更改单元格时，VBA代码不会运行

1 个答案: