VBA change shape color based on cell value

[noelmus]

Hi
I am using a code so that the shape changes the color when a cell value is changed.
My problem is that cell J24 is changing as a result of a formula recalculating. So what I have to change in my code shown below to make it work?
I prefer that the code will work for 2 shapes since I need to add another shape.

Thanks in advance

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("J24")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value < 80000 Then
ActiveSheet.Shapes("LevelA").Fill.ForeColor.RGB = vbRed
ElseIf Target.Value >= 80000 And Target.Value < 400000 Then
ActiveSheet.Shapes("LevelA").Fill.ForeColor.RGB = vbYellow
Else
ActiveSheet.Shapes("LevelA").Fill.ForeColor.RGB = vbGreen
End If
End If
End Sub

 

[mumps]

Replace the current macro in the worksheet code module with this one:

Private Sub Worksheet_Calculate()
    Dim shp As Shape
    If IsNumeric(Range("J24")) Then
        For Each shp In ActiveSheet.Shapes
            If Range("J24").Value < 80000 Then
               shp.Fill.ForeColor.RGB = vbRed
            ElseIf Range("J24").Value >= 80000 And Range("J24").Value < 400000 Then
               shp.Fill.ForeColor.RGB = vbYellow
            Else
                shp.Fill.ForeColor.RGB = vbGreen
            End If
        Next shp
    End If
End Sub

 

[noelmus]

Hi,
First of all thanks for your reply.
When I put your code it gave me a Compile error:
Ambiguous name dedected:
Worksheet_Calculate.
Just to let you know that I have already a code in worksheet code module. Is this makes any difference?

 

[mumps]

You can't have more than one worksheet event macro with the same name. Can you post the macro you already have?

 

[noelmus]

OK here below:

Option Explicit


Private Sub AdjustTank(ByVal CurLevel As Double, ByVal TankID As String, _
Optional MaxLevel As Double = 400000)
Dim Tank As Shape, Frame As Shape, Level As Shape, Number As Shape
'Refer to he Tank shape
Set Tank = Me.Shapes("Tank" & TankID)
'Refer to the shapes inside
Set Frame = Tank.GroupItems("FrameA")
Set Level = Tank.GroupItems("LevelA")
Set Number = Tank.GroupItems("NumberA")

'Be sure the new level is not above the max level
If CurLevel > MaxLevel Then CurLevel = MaxLevel
'Write the new level number into the TextBox
Number.TextFrame2.TextRange.Text = Format(CurLevel, "#,##0")

'Calculate the height of the level according to the max. level
Level.Height = (Frame.Height - 2) / MaxLevel * CurLevel
'Move the level to the bottom
Level.Top = Frame.Top + Frame.Height - Level.Height - 1

'Move the number into the middle
Number.Left = Frame.Left + Frame.Width / 2 - Number.Width / 2
'And below the level line
Number.Top = Level.Top - 3
'If the number is too low move it to the lowest possible position
If Number.Top + Number.Height > Frame.Top + Frame.Height Then
Number.Top = Level.Top - Number.Height + 3
End If
End Sub


Private Sub Worksheet_Calculate()
Static LastValueJ, LastValueH
With Range("j24")
If LastValueJ <> .Value Then
AdjustTank .Value, "A"
LastValueJ = .Value


End If


End With


With Range("H24")
If LastValueH <> .Value Then
AdjustTank .Value, "B"
LastValueH = .Value


End If


End With


End Sub


Sub test()
Me.Shapes("BackGroundA").Left = Me.Shapes("FrameA").Left
Me.Shapes("BackGroundA").Top = Me.Shapes("FrameA").Top
End Sub

 

[mumps]

Give this a try:

Private Sub Worksheet_Calculate()
    Static LastValueJ, LastValueH
    Dim shp As Shape
    If IsNumeric(Range("J24")) Then
        For Each shp In ActiveSheet.Shapes
            If Range("J24").Value < 80000 Then
               shp.Fill.ForeColor.RGB = vbRed
            ElseIf Range("J24").Value >= 80000 And Range("J24").Value < 400000 Then
               shp.Fill.ForeColor.RGB = vbYellow
            Else
                shp.Fill.ForeColor.RGB = vbGreen
            End If
        Next shp
    End If

    With Range("j24")
        If LastValueJ <> .Value Then
            AdjustTank .Value, "A"
            LastValueJ = .Value
        End If
    End With
    With Range("H24")
        If LastValueH <> .Value Then
            AdjustTank .Value, "B"
            LastValueH = .Value
        End If
    End With
End Sub

Also, please use code tags when posting code. Highlight the code and then click the # sign in the menu. Please edit your post and add the tags.

 

[noelmus]

Hi,
It didn't work.

 

[mumps]

Did you get any errors? Was there a change in cell J24 as a result of the formula? How did it not work?

 

[noelmus]

Yes there was a change in cell J24 and the error was:
Run-time error 2147024809(80070057)
The specified value is out of range.
To let you know what i did is, I removed this code below and replaced it by yours.

Private Sub Worksheet_Calculate()
Static LastValueJ, LastValueH
With Range("j24")
If LastValueJ <> .Value Then
AdjustTank .Value, "A"
LastValueJ = .Value


End If


End With


With Range("H24")
If LastValueH <> .Value Then
AdjustTank .Value, "B"
LastValueH = .Value


End If


End With


End Sub

 

[mumps]

I tried the code I suggested in a dummy sheet and it worked properly. I think that it would be easier to help and test possible solutions if I could work with your actual file which includes any macros you are currently using. Perhaps you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do using a few examples from your data and referring to specific cells, rows, columns and worksheets. If the workbook contains confidential information, you could replace it with generic data.