Private Sub Worksheet_Calculate（）

Question

我無法發佈圖片，所以我想更詳細地解釋我的問題。

我有2個文件：vlookup公式在目標文件中。 vlookup值位於源文件中。目標文件將被關閉。源文件將被打開。在源文件中，我可以更改15個單元格值。如果是這樣，我希望目標文件（關閉的工作簿）中的15個單元格以黃色突出顯示，因爲它們在打開時包含了vlookups。我希望這能解釋我們正在努力解決的問題。

Answer 1

它看起來像你想建立類似於交易平臺的東西，以突出顯示與RTD公式鏈接的單元格。如果它是真的（或者甚至手動進行更改），則可以使用worksheet_change實現您的目標。

以下過程查看第12到15列（實時值發生變化）中的單元格，並比較計算出現之前和之後的FmlaRng中的值（我假設它是一個固定範圍）。將工作表設置爲xlCalculateManual非常重要，否則Excel將計算新值，然後才能記錄舊值。

此外，我不確定是否需要保留Application.EnableEvents，但我將它留在那裏。

Private Sub Worksheet_Change(ByVal Target As Range) 
Dim endrow As Long, startrow As Long, i As Long, j As Long 
Dim PreValue As Variant 
Dim FmlaRng As Range 

Application.EnableEvents = False 
Application.Calculation = xlCalculationManual 
If Target.Column >= 12 And Target.Column <= 15 Then 'This is where the cell initally changes (the lookupvalue cells) 
    On Error GoTo 0 
    startrow = 1 
    endrow = 1000 
    With Workbooks("Workbook2").sheets("Sheet1") 'You need to change these names 
    Set FmlaRng = .Range(.Cells(startrow, 94), .Cells(endrow, 100)) 'FmlaRng is where the lookups should be 
    FmlaRng.Cells.Interior.ColorIndex = 0 
    PreValue = FmlaRng 
    Calculate 'This is when vlookups update 
    For i = LBound(PreValue, 1) To UBound(PreValue, 1) 
     For j = LBound(PreValue, 2) To UBound(PreValue, 2) 
      If FmlaRng.Cells(i, j) = PreValue(i, j) Then 
      Else 
       FmlaRng.Cells(i, j).Interior.ColorIndex = 36 
      End If 
     Next j 
    Next i 
    End with 
End If 
Application.EnableEvents = True 
End Sub 

Answer 2

UPDATE

而是突出細胞的，你知道如何在每一個單元格中插入註釋每當單元格的值變化呢？我想評論說，「細胞從20改爲30」。

嘗試這個代碼（可能是耗時的用於與式大範圍）：

代碼模塊中（非標準模塊）：

Public cVals As New Dictionary 

Sub populateDict() 
    Dim rng As Range, c As Range 

    With ThisWorkbook.Worksheets("Sheet1") 
     Set rng = Intersect(.UsedRange, .Range("CP:CV")) 
     If rng Is Nothing Then Exit Sub 
     For Each c In rng 
      cVals(c.Address) = c.Text 
     Next c 
     .Calculate 
    End With 
End Sub 

中的ThisWorkbook模塊：

Private Sub Workbook_Open() 
    Application.Calculation = xlCalculationManual 
    Call populateDict 
    Application.Calculation = xlCalculationAutomatic 
End Sub 

中板模塊：

Private Sub Worksheet_Calculate() 
    Dim rng As Range, c As Range 
    Dim rngToColor As Range 

    On Error GoTo ErrorHandler 

    Application.EnableEvents = False 
    'get only used part of the sheet 
    Set rng = Intersect(Me.UsedRange, Me.Range("CP:CV")) 
    If rng Is Nothing Then GoTo ExitHere ' if there is no formulas in CP:CV - exit from sub 

    'reset color for all cells 
    rng.Interior.Color = xlNone 
    For Each c In rng 
     'check if previous value of this cell not equal to current value 
     If cVals(c.Address) <> c.Text Then 
      'if so (they're not equal), remember this cell 
      c.ClearComments 
      c.AddComment Text:="Changed value from '" & cVals(c.Address) & "' to '" & c.Text & "'" 
     End If 
     'store current value of cell in dictionary (with key=cell address) 
     cVals(c.Address) = c.Text 
    Next c 

ExitHere: 
    Application.EnableEvents = True 
    Exit Sub 
ErrorHandler: 
    Resume ExitHere 
End Sub 

請注意，我uisng Dictionary對象。對於使用Dictionary對象，您應該添加對Microsoft Scripting Runtime庫的引用。轉到工具 - >引用並選擇Microsoft Scripting Runtime庫：