Private Sub Worksheet_Calculate() [closed] - vba

Question

Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question appears to be off-topic because it lacks sufficient information to diagnose the problem. Describe your problem in more detail or include a minimal example in the question itself.
Closed 8 years ago.
Improve this question
I can't post an image so I wanted to explain my question in more detail.
I have 2 files: The vlookup formulas are in the Destination File. The vlookup values are in the Source File. The Destination File will be closed. The Source File will be opened. In the Source File, I may change 15 cell values. If so, I want the 15 cells in the Destination File (closed workbook) to be highlighted yellow as they contain the vlookups when I open it. I hope this explains what we're trying to solve.

Answer 1

UPDATE
Instead of highlighting the cells, do you know how to insert a comment in each cell whenever the cell value changes? I would like to comment to say, "Changed cell from 20 to 30".
Try this code (may be time consuming for big ranges with formulas):
in Code module (standart module):
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
in ThisWorkbook module:
Private Sub Workbook_Open()
Application.Calculation = xlCalculationManual
Call populateDict
Application.Calculation = xlCalculationAutomatic
End Sub
in Sheet module:
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
Note that I'm uisng Dictionary object. For working with Dictionary object you should add reference to Microsoft Scripting Runtime library. Go to Tools->References and select Microsoft Scripting Runtime library:

Answer 2

It looks like you want to build something similar to a trading platform to highlight cells linked with RTD formulas. If it is true (or even if you make changes manually), you can achieve your goal by using worksheet_change.
The below procedure looks at cells in columns 12 to 15 (the real-time values that change) and it compares the values in the FmlaRng (which I assume is a fixed range) before the calculate occurs and after. It is important you set your sheet as xlCalculateManual otherwise Excel will calculate the new values before you can record the old ones.
Also, I am not sure if you need to keep the Application.EnableEvents, but I left it there.
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