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

Question

我为“配置文件”工作表上发生的任何更改创建了审计跟踪。在配置文件中进行的任何更改都记录在另一个工作表中 - 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

有可能是一个更好的方式来做到这一点，但这是来到我的脑海：

In Profile Sheet Module

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上做了一些上述代码的小测试，但您可能想要进行更广泛的测试以确保所有更改都通过上述代码捕获。