How can I run VBA code each time a cell gets its value changed by a formula?

Question

How can I run a VBA function each time a cell gets its value changed by a formula?

I've managed to run code when a cell gets its value changed by the user, but it doesn't work when the value is changed due to a formula referencing another cell.

Answer 1

If I have a formula in cell A1 (e.g. = B1 * C1) and I want to run some VBA code each time A1 changes due to updates to either cell B1 or C1 then I can use the following:

Private Sub Worksheet_Calculate()
    Dim target As Range
    Set target = Range("A1")

    If Not Intersect(target, Range("A1")) Is Nothing Then
    //Run my VBA code
    End If
End Sub

---

Update

As far as I know the problem with Worksheet_Calculate is that it fires for all cells containing formulae on the spreadsheet and you cannot determine which cell has been re-calculated (i.e. Worksheet_Calculate does not provide a Target object)

To get around this, if you have a bunch of formulas in column A and you want to identify which one has updated and add a comment to that specific cell then I think the following code will achieve that:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim updatedCell As Range
    Set updatedCell = Range(Target.Dependents.Address)

    If Not Intersect(updatedCell, Range("A:A")) Is Nothing Then
       updatedCell.AddComment ("My Comments")
    End If

End Sub

To explain, for a formula to update, one of the input cells into that formula must change e.g. if formula in A1 is =B1 * C1 then either B1 or C1 must change to update A1.

We can use the Worksheet_Change event to detect a cell change on the s/sheet and then use Excel's auditing functionality to trace the dependents e.g. cell A1 is dependent on both B1 and C1 and, in this instance, the code Target.Dependents.Address would return $A$1 for any change to B1 or C1.

Given this, all we now need to do is to check if the dependent address is in column A (using Intersect). If it is in Column A we can then add comments to the appropriate cell.

Note that this only works for adding comments once only into a cell. If you want to continue to overwrite comments in the same cell you would need to modify the code to check for the existance of comments first and then delete as required.

Answer 2

The code you used does not work because the cell changing is not the cell with the formula but the cell... being changed :)

Here is what you should add to the worksheet's module:

(Updated: The line "Set rDependents = Target.Dependents" will raise an Error if there are no dependents. This update takes care of this.)

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rDependents As Range
    
    On Error Resume Next
    Set rDependents = Target.Dependents
    If Err.Number > 0 Then
        Exit Sub
    End If
    ' If the cell with the formula is "F160", for example...
    If Not Application.Intersect(rDependents, Range("F160")) Is Nothing Then
        Call abc
    End If
End Sub

Private Sub abc()
    MsgBox """abc()"" is running now"
End Sub

You can expand this if there are many dependent cells by setting up an array of cell addresses in question. Then you would test for each address in the array (you can use any looping structure for this) and run a desired subroutine corresponding to the changed cell (use SELECT CASE...) for this.

Answer 3

Here is another way using classes. The class can store cell Initial value and cell address. On calculate event it will compare the address current value with the stored initial value. Example below is made to listen to one cell only ("A2"), but you can initiate listening to more cells in the module or change the class to work with wider ranges.

Class module called "Class1":

Public WithEvents MySheet As Worksheet
Public MyRange As Range
Public MyIniVal As Variant

Public Sub Initialize_MySheet(Sh As Worksheet, Ran As Range)
    Set MySheet = Sh
    Set MyRange = Ran
    MyIniVal = Ran.Value
End Sub
Private Sub MySheet_Calculate()

If MyRange.Value <> MyIniVal Then
    Debug.Print MyRange.Address & " was changed from " & MyIniVal & " to " & MyRange.Value
    StartClass
End If

End Sub

Initialize the class in normall module.

Dim MyClass As Class1

Sub StartClass()
Set MyClass = Nothing
Set MyClass = New Class1
MyClass.Initialize_MySheet ActiveSheet, Range("A2")
End Sub

Answer 4

Here is my code:

I know it looks terrible, but it works! Of course there are solutions which are much better.

Description of the code:

When the Workbook opens, the value of the cells B15 till N15 are saved in the variable PrevValb till PrevValn. If a Worksheet_Calculate() event occurs, the previous values are compared with the actual values of the cells. If there is a change of the value, the cell is marked with red color. This code could be written with functions, so that he is much shorter and easier to read. There's a color-reset-button (Seenchanges), which resets the color to the previous color.

Workbook:

Private Sub Workbook_Open()
PrevValb = Tabelle1.Range("B15").Value
PrevValc = Tabelle1.Range("C15").Value
PrevVald = Tabelle1.Range("D15").Value
PrevVale = Tabelle1.Range("E15").Value
PrevValf = Tabelle1.Range("F15").Value
PrevValg = Tabelle1.Range("G15").Value
PrevValh = Tabelle1.Range("H15").Value
PrevVali = Tabelle1.Range("I15").Value
PrevValj = Tabelle1.Range("J15").Value
PrevValk = Tabelle1.Range("K15").Value
PrevVall = Tabelle1.Range("L15").Value
PrevValm = Tabelle1.Range("M15").Value
PrevValn = Tabelle1.Range("N15").Value
End Sub

Modul:

Sub Seenchanges_Klicken()
Range("B15:N15").Interior.Color = RGB(252, 213, 180)
End Sub

Sheet1:

Private Sub Worksheet_Calculate()
If Range("B15").Value <> PrevValb Then
    Range("B15").Interior.Color = RGB(255, 0, 0)
    PrevValb = Range("B15").Value
End If
If Range("C15").Value <> PrevValc Then
    Range("C15").Interior.Color = RGB(255, 0, 0)
    PrevValc = Range("C15").Value
End If
If Range("D15").Value <> PrevVald Then
    Range("D15").Interior.Color = RGB(255, 0, 0)
    PrevVald = Range("D15").Value
End If
If Range("E15").Value <> PrevVale Then
    Range("E15").Interior.Color = RGB(255, 0, 0)
    PrevVale = Range("E15").Value
End If
If Range("F15").Value <> PrevValf Then
    Range("F15").Interior.Color = RGB(255, 0, 0)
    PrevValf = Range("F15").Value
End If
If Range("G15").Value <> PrevValg Then
    Range("G15").Interior.Color = RGB(255, 0, 0)
    PrevValg = Range("G15").Value
End If
If Range("H15").Value <> PrevValh Then
    Range("H15").Interior.Color = RGB(255, 0, 0)
    PrevValh = Range("H15").Value
End If
If Range("I15").Value <> PrevVali Then
    Range("I15").Interior.Color = RGB(255, 0, 0)
    PrevVali = Range("I15").Value
End If
If Range("J15").Value <> PrevValj Then
    Range("J15").Interior.Color = RGB(255, 0, 0)
    PrevValj = Range("J15").Value
End If
If Range("K15").Value <> PrevValk Then
    Range("K15").Interior.Color = RGB(255, 0, 0)
    PrevValk = Range("K15").Value
End If
If Range("L15").Value <> PrevVall Then
    Range("L15").Interior.Color = RGB(255, 0, 0)
    PrevVall = Range("L15").Value
End If
If Range("M15").Value <> PrevValm Then
    Range("M15").Interior.Color = RGB(255, 0, 0)
    PrevValm = Range("M15").Value
End If
If Range("N15").Value <> PrevValn Then
    Range("N15").Interior.Color = RGB(255, 0, 0)
    PrevValn = Range("N15").Value
End If
End Sub