Hello,

I am working on a way to have Shapes change color depending on the values in
a cell.

Current worksheet has the following table. Where Rect 1 to 9 are the shapes
that i want to vary in color depending on the selection of either 2007 or
2008 data. (selection in column D below)

2007 2008 2007
rect1 5% 15% 5.0%
rect2 1% 24% 1.0%
rect3 13% 30% 13.0%
rect4 22% 9% 22.0%
rect5 40% 10% 40.0%
rect6 30% 20% 30.0%

Colors of the shapes will vary depending on thresholds established in a table:

Threshold RGB code Explanation
0 255 < 5.00%
5% 49407 = 5.00% & < 12.00%
12.00% 65535 = 12.00% & < 20.00%
20.00% 16744192 = 20.00% & < 25.00%
25.00% 11075328 = 25.00%

Now i found a website that gave me the following code. I followed the
instructions exactly.

Giving credit where it is due...the results on the website are very cool and
exactly what i am looking to replicate. Unfortunately, i feel like i am
missing something.

The results i am getting in terms of the colors in each shape are not
corresponding to the threshold table above.

Thanks for your help.

http://www.tushar-mehta.com/excel/ch...e%20colors.htm
__________________________________________________ _______


The following code is in a module:

Option Explicit
Sub CheckColor(aCell As Range)
Dim aShp As Shape, TargCell As Range
On Error GoTo Catch1
Set TargCell = Range("shapetoname").Columns(1).Find( _
aCell.Name.Name, LookAt:=xlWhole)
Set aShp = ActiveSheet.Shapes(TargCell.Offset(0, 1))
GoTo Finally1
Catch1:
Exit Sub
Finally1:
On Error GoTo 0
Dim ColorCode As Long
If aCell.Value < Range("Threshold").Cells(2, 1).Value Then
ColorCode = Range("Threshold").Cells(1, 2).Value
Else
ColorCode = Application.WorksheetFunction.VLookup( _
aCell.Value, Range("Threshold"), 2, True)
End If
aShp.Fill.ForeColor.RGB = ColorCode
End Sub

Sub updateAll()
Dim aCell As Range
For Each aCell In Range("shapetoname").Columns(1).Cells
CheckColor Range(aCell.Value)
Next aCell
End Sub

Function VBA_RGB(R As Byte, G As Byte, B As Byte) As Long
VBA_RGB = RGB(R, G, B)
End Function

The follow code is in Sheet 1

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
For Each aCell In Target
If InStr(1, Range("UpdateAllCells").Value, _
aCell.Address(True, True), vbTextCompare) 0 Then
updateAll
Else
CheckColor aCell
End If
Next aCell
End Sub