當公式或外部鏈接更改單元格時，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上做了一些上述代碼的小測試，但您可能想要進行更廣泛的測試以確保所有更改都通過上述代碼捕獲。