Change colour of multiple shapes in a Chart???????? HELP!

[harteorama]

Hi all,

Can anybody please help... i have the code below that changes the Shape
(Freeform 13) on a Chart2 tab, in Sheet1 in cell a9, is a value that
determines the colour of the shape.. and this works fine... the
question is, how do i modify this code so that i can add other shapes
to the Chart2 i.e. Freeform 11, 12 etc.. with the colour determined
from cells A10, A11 in sheet1... ?? i am trying to get a map of the uk
- by region - to change colour depending the status (number value) in a
cell....

any help.. REALLY appreciated...

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myColor As Long
Dim myShape As Shape

If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Me.Range("a9")) Is Nothing Then Exit Sub

' chart object not worksheet
Set myShape = Charts("Chart2").Shapes("Freeform 13")

' non textual comparison
Select Case Target.Value
Case Is > 1: myColor = 53
Case Is < 1: myColor = 33
Case Is = 1: myColor = 25
Case Else
myColor = 0
End Select
If myColor = 0 Then
myShape.Fill.Visible = False
Else
With myShape.Fill
.Visible = True
.ForeColor.SchemeColor = myColor
End With
End If

End Sub

cheers

P

 

[Dave Peterson]

Do you use the same rules to determine the colors?

If yes, maybe you can modify this untested (but compiled ok!) code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myColor As Long
Dim myShapeNames As Variant
Dim myAddr As Variant
Dim iCtr As Long
Dim myShape As Shape

If Target.Cells.Count > 1 Then Exit Sub

myAddr = Array("a9", "b13", "C22")
myShapeNames = Array("Freeform 13", "Freeform 14", "Freeform 15")

If UBound(myAddr) <> UBound(myShapeNames) Then
MsgBox "Design error #1"
Exit Sub
End If

For iCtr = LBound(myAddr) To UBound(myAddr)
If Not Intersect(Target, Me.Range(myAddr(iCtr))) Is Nothing Then
Set myShape = Nothing
On Error Resume Next
Set myShape = Charts("Chart2").Shapes(myShapeNames(iCtr))
On Error GoTo 0
If myShape Is Nothing Then
MsgBox "Design error #2"
Exit Sub
End If

Select Case Target.Value
Case Is > 1: myColor = 53
Case Is < 1: myColor = 33
Case Is = 1: myColor = 25
Case Else
myColor = 0
End Select
If myColor = 0 Then
myShape.Fill.Visible = False
Else
With myShape.Fill
.Visible = True
.ForeColor.SchemeColor = myColor
End With
End If
End If
Next iCtr

End Sub

 

[Dave Peterson]

Since you're checking to make sure only one cell is changed, you could leave
that "for each" loop after it finds the one cell that got changed:

For iCtr = LBound(myAddr) To UBound(myAddr)
If Not Intersect(Target, Me.Range(myAddr(iCtr))) Is Nothing Then
Set myShape = Nothing
On Error Resume Next
Set myShape = Charts("Chart2").Shapes(myShapeNames(iCtr))
On Error GoTo 0
If myShape Is Nothing Then
MsgBox "Design error #2"
Exit Sub
End If

Select Case Target.Value
Case Is > 1: myColor = 53
Case Is < 1: myColor = 33
Case Is = 1: myColor = 25
Case Else
myColor = 0
End Select
If myColor = 0 Then
myShape.Fill.Visible = False
Else
With myShape.Fill
.Visible = True
.ForeColor.SchemeColor = myColor
End With
End If
Exit For '<-- added
End If
Next iCtr

 

[harteorama]

Dave,


you are officially my hero... worked like a dream.. many many many
thanks....

have a fantastic new year...


all the very best

Paul

 

[Dave Peterson]

Woohoo!

Glad it worked.

Dave,

you are officially my hero... worked like a dream.. many many many
thanks....

have a fantastic new year...

all the very best

Paul