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

  • Thread starter Thread starter harteorama
  • Start date Start date
H

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
 
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
 
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
 
Dave,


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

have a fantastic new year...


all the very best

Paul
 
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
Click to expand...
 
Back
Top