Change color of Shape based on condition - Macro?

[Guest]

I need to have an auto shape, just a regular rectangle, change color based on
a cell next to it. The cell next to it contains an IF statement to either
put a 1 or a 0 depending on another sheet. I would like the button color to
be grey 25% if the if statement result is 0 and light green if the if
statement result is 1. Does anyone know how this could work?

Thanks!

 

[Chip Pearson]

The following code will get you started. You'll have to change the RGB
colors to get the colors you want. Put this code in the ThisWorkbook code
module.

Private Sub Workbook_SheetCalculate(ByVal SH As Object)
Dim Rng As Range
Dim ShapeName As String
Dim SHP As Shape

'''''''''''''''''''''''''''''
' Change the shape name
' to your shape's name.
'''''''''''''''''''''''''''''
ShapeName = "Rectangle 1"
'''''''''''''''''''''''''''''
' Change this range to the
' appropriate sheet and cell.
'''''''''''''''''''''''''''''
Set Rng = ThisWorkbook.Worksheets("Sheet1").Range("F9")
Set SHP = Rng.Parent.Shapes(ShapeName)

If Rng.Value = 0 Then
SHP.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
SHP.Fill.ForeColor.RGB = RGB(0, 255, 0) ' green
End If

End Sub



--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com
(email address is on the web site)

 

[Guest]

Chip -

This works perfectly! I have a follow up though... Is there an easier way
if I have 24 rectangles to change color based on 24 different cells to do a
code instead of copying code 24 times?

 

[Chip Pearson]

IF the cell that controls the shape's color is the Top Left Cell of the
shape, you could use code like the following. As before, adjust the RGB
values to the colors you want.

Private Sub Workbook_SheetCalculate(ByVal SH As Object)
Dim SHP As Shape
Dim TLC As Range
For Each SHP In SH.Shapes
Set TLC = SHP.TopLeftCell
If TLC.Value = 0 Then
SHP.Fill.ForeColor.RGB = RGB(255, 0, 0) 'red
Else
SHP.Fill.ForeColor.RGB = RGB(0, 255, 0) 'green
End If
Next SHP
End Sub



--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com
(email address is on the web site)