Run Macro on Change of formula result value in cell

High Plains Grifter

Board Regular
Joined
Mar 9, 2010
Messages
129
Hello Excellent people!

I have made a macro which is designed to change the colour of some shapes depending on the value in a cell. It all works fine when it runs, but it only runs when I exit the formula bar of the cell. Since the taget cell has a formula in it (basic division of two numbers to give a percentage), the displayed value in the cell can change without the user entering the formula bar.

I would like the shapes to change colour when the displayed value in the cell changes, even though the cell (as it will be) is locked for editing, so no one will be actually clicking on it. The cell may even be hidden eventually.

Is this possible?

Just for reference, my code is as follows (it makes traffic lights at the moment, but it will grow :¬)

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'once we have the action, we need no more events
Application.EnableEvents = False
Dim Red As Integer
Dim Green As Integer
Dim Orange As Integer
Dim Off As Integer
'Set the colours with the matching Schemecolor values
Red = 2
Orange = 52
Green = 3
Off = 74
'
If Target.Address = "$A$1" Then
    Select Case Target.Value
        Case 0 To 33.33
                ActiveSheet.Shapes.Range(Array("RedLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Red
'
                ActiveSheet.Shapes.Range(Array("OrangeLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("GreenLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
        Case 33.33 To 66.67
                ActiveSheet.Shapes.Range(Array("RedLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("OrangeLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Orange
'
                ActiveSheet.Shapes.Range(Array("GreenLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
        Case 66.67 To 1000.5
                ActiveSheet.Shapes.Range(Array("RedLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("OrangeLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("GreenLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Green
    End Select
        'take the select box off the picture cos it looks nasty
        Range("A1").Activate
        'let the fella have his fun again
        Application.EnableEvents = True
End If
'
End Sub
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
34,317
Office Version
365, 2019, 2016, 2010
Platform
Windows, MacOS
You either need the Calculate event, or you need your Change event to monitor the input cells, not the formula cell.
 

VoG

Legend
Joined
Jun 19, 2002
Messages
63,651
Try

Code:
Private Sub Worksheet_Calculate()
'once we have the action, we need no more events
Application.EnableEvents = False
Dim Red As Integer
Dim Green As Integer
Dim Orange As Integer
Dim Off As Integer
'Set the colours with the matching Schemecolor values
Red = 2
Orange = 52
Green = 3
Off = 74
'
    Select Case Range("A1").Value
        Case 0 To 33.33
                ActiveSheet.Shapes.Range(Array("RedLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Red
'
                ActiveSheet.Shapes.Range(Array("OrangeLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("GreenLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
        Case 33.33 To 66.67
                ActiveSheet.Shapes.Range(Array("RedLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("OrangeLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Orange
'
                ActiveSheet.Shapes.Range(Array("GreenLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
        Case 66.67 To 1000.5
                ActiveSheet.Shapes.Range(Array("RedLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("OrangeLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Off
'
                ActiveSheet.Shapes.Range(Array("GreenLight")).Select
                Selection.ShapeRange.Fill.ForeColor.SchemeColor = Green
    End Select
        'take the select box off the picture cos it looks nasty
        Range("A1").Activate
        'let the fella have his fun again
        Application.EnableEvents = True
'
End Sub
 

Forum statistics

Threads
1,081,526
Messages
5,359,287
Members
400,524
Latest member
Excelbat

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top