Fill color in autoshape based on cell data

[Guest]

Dear Experts

I have a range of cells with an autoshape in each cell. I would like to have the fill color of the autoshape change based on the results of an if statement in each cell. The if statment would return "G", "R", & "Y". The fill colors would be green, red, and yellow. I don't want conditional formatting for the cell fill color, only conditional formatting for the shape

I was thinking a select case macro, but can't seem to get the code correct. However, I am a novice at macros

Thanks for any assistance
Jodi

 

[Debra Dalgleish]

You could use the worksheet change event to colour the shapes, if the
cell values are changed by typing. For example:

'============================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape

If Target.Count > 1 Then Exit Sub
Select Case UCase(Target.Value)
Case "Y"
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = Target.Address Then
shp.Fill.ForeColor.SchemeColor = 13
Exit Sub
End If
Next shp
Case "G"
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = Target.Address Then
shp.Fill.ForeColor.SchemeColor = 57
Exit Sub
End If
Next shp
Case "R"
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = Target.Address Then
shp.Fill.ForeColor.SchemeColor = 10
Exit Sub
End If
Next shp
Case Else
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = Target.Address Then
shp.Fill.ForeColor.SchemeColor = xlNone
Exit Sub
End If
Next shp
End Select
End Sub
'===============================

 

[Dave Peterson]

First, if you're going to change colors based on a formula (if statement),
you'll need to use a worksheet event.

But some setup first.

To make life easier, I'd name all my shapes in the same pattern: xxxxx_yy.
Some set of characters followed by an underscore, then followed by the cell's
address that controls it.

Shape_A1
Box_B9
mylongname_c3

Then you can easily tie the cell back to the shape.

If that's ok, then right click on the worksheet tab that should have this
behavior. Select view code and paste this into the code window:

Option Explicit
Private Sub Worksheet_Calculate()

Dim myShape As Shape
Dim testRng As Range
Dim UnderScorePos As Long
Dim myColor As Long

For Each myShape In Me.Shapes
UnderScorePos = InStr(myShape.Name, "_")
If UnderScorePos > 0 Then
Set testRng = Nothing
On Error Resume Next
Set testRng = Me.Range(Mid(myShape.Name, UnderScorePos + 1))
On Error GoTo 0
If testRng Is Nothing Then
'no link back to a cell
Else
Select Case LCase(testRng.Value)
Case Is = "r": myColor = 10
Case Is = "y": myColor = 13
Case Is = "g": myColor = 11
Case Else: myColor = 99999
End Select
With myShape.Fill
If myColor <> 99999 Then
.ForeColor.SchemeColor = myColor
.Visible = msoTrue
Else
.Visible = msoFalse
End If
End With
End If
End If
Next myShape

End Sub

Back to excel and make some changes to make the worksheet recalculate

 

[Dave Peterson]

When you want to change the name of an object, you can click on it and type over
the name in the namebox (that little dropdown area that usually shows the range
address when you're in a cell). It's to the left of the formula bar.

In fact, I usually right click on the little suckers. I find it easier to
select them that way.

Don't forget to hit enter after you finish typing your new name.

Me is a keyword that refers to the thing holding the code. In this case, it
refers to the worksheet that will soon have this behavior.

If you use me in the ThisWorkbook module, it'll refer to workbook itself.

A lot like the word in common English. It'll refer to the speaker and that
depends on who is doing the speaking <bg>.