How to Changing fill color of autoshapes based on result of formula in a cell

How to change fill color of autoshapes based on result of formula in a cell

Requirement:

The user is looking to change the colour of a shape (Rectangle 25) based on the out come of a formula running in another cell. The formula [=SUM('Back Log'!H10:H16)/SUM('Back Log'!F10:F16)] currently returns a value of 0.0138. If the value returned is less than or equal to 0.01, the user wants the shape to turn green, otherwise the user wants it to be red.

Following the advice in this post http://www.ozgrid.com/forum/showthread.php?t=52064 the user has got the code below.

The issue the user is having is the macro runs fine when the value is a number the user inputs, the issue is when the user inputs the formula it doesn't work.

VBA:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("F29")) Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) Then
        If Target.Value <= 0.01 Then
            ActiveSheet.Shapes("Rectangle 25").Fill.ForeColor.RGB = vbGreen
        Else
            ActiveSheet.Shapes("Rectangle 25").Fill.ForeColor.RGB = vbRed
        End If
    End If
End Sub

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/148161-changing-fill-color-of-autoshapes-based-on-result-of-formula-in-a-cell

Solution:

Code:

Sub formatShape(rg As Range, sh As Shape, sCrit As String)
    Dim bEval                 As Boolean
    On Error Resume Next
    bEval = rg.Worksheet.Evaluate(rg.Address & sCrit)


    If bEval Then
        sh.Fill.ForeColor.RGB = vbGreen
    Else
        sh.Fill.ForeColor.RGB = vbRed
    End If
End Sub


Private Sub Worksheet_Calculate()
    formatShape Range("F29"), ActiveSheet.Shapes("Rectangle 25"), "<=0.01"
     ' and repeat as needed
    formatShape Range("G29"), ActiveSheet.Shapes("Rectangle 26"), "=0" ' for example
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by rory.