Change color of multiple autoshapes

  • Thread starter Thread starter T-bone
  • Start date Start date
T

T-bone

I need to change the color of several autoshape based on different cells

I know how to change one autoshape using a worksheet_change event
but i can't just copy and paste this and change the object name + cell name.

is it possible to have multiple worksheet_change events in the same
worksheet??
 
T-bone,

You have only one worksheet_change event, but in it you can test to see which cell was
changed with something like

If not Intersect(Target, Range("A1") is nothing then
' do range A1 stuff here
end if
If not Intersect(Target, Range("A2") is nothing then
' do range A2 stuff here
end if
 
Hey Earl,
thanks for your reply
but i don't think i have explained this well enough

hopefully this will help

i have 6 objects named "Object(1-6)"
i have 6 cells named "Cella(1-6)"
i have another 6 cells named "Cellb(1-6)"

i want object 1 ("Object1") to be filled green if
"Cella1" is greater than "Cellb1"
i want object 1 ("Object1") to be filled yellow if
"Cella1" is equal to "Cellb1"
i want object 1 ("Object1") to be filled red if
"Cella1" is less to "Cellb"

i want "Object 2" to be filled green if
"Cella2" is greater than "Cellb2"
i want "Object 2" to be filled yellow if
"Cella2" is equal to "Cellb2"
i want "Object 2" to be filled red if
"Cella2" is less to "Cellb2"

and so on for each of the 6 objects

can you please help with this

T.
 
In my simpler test, I put 2 ovals from the Drawing toolbar and added names to 4
cells.

The ovals were named Object1 and Object2.
The cells were named CellA1, CellB1, CellA2 and CellB2.

This seemed to work ok:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myShape As Shape
Dim CellA As Range
Dim CellB As Range
Dim iCtr As Long
Dim myColor As Long

With Me
For iCtr = 1 To 2 'You'll change this to 6
Set myShape = Nothing
Set CellA = Nothing
Set CellB = Nothing
On Error Resume Next
Set myShape = .Shapes("Object" & iCtr)
Set CellA = .Range("CellA" & iCtr)
Set CellB = .Range("CellB" & iCtr)
On Error GoTo 0

If myShape Is Nothing _
Or CellA Is Nothing _
Or CellB Is Nothing Then
MsgBox "Design error with Object/CellA/CellB " & iCtr
Else
If Intersect(Target, Union(CellA, CellB)) Is Nothing Then
'do nothing
Else
If CellA.Value > CellB.Value Then
myColor = 11
ElseIf CellA.Value = CellB.Value Then
myColor = 13
Else
myColor = 10
End If
myShape.OLEFormat.Object.ShapeRange _
.Fill.ForeColor.SchemeColor = myColor
End If
End If
Next iCtr
End With

End Sub
 
Dave you are a GENIUS

Thank you so much!!

Dave Peterson said:
In my simpler test, I put 2 ovals from the Drawing toolbar and added names to 4
cells.

The ovals were named Object1 and Object2.
The cells were named CellA1, CellB1, CellA2 and CellB2.

This seemed to work ok:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myShape As Shape
Dim CellA As Range
Dim CellB As Range
Dim iCtr As Long
Dim myColor As Long

With Me
For iCtr = 1 To 2 'You'll change this to 6
Set myShape = Nothing
Set CellA = Nothing
Set CellB = Nothing
On Error Resume Next
Set myShape = .Shapes("Object" & iCtr)
Set CellA = .Range("CellA" & iCtr)
Set CellB = .Range("CellB" & iCtr)
On Error GoTo 0

If myShape Is Nothing _
Or CellA Is Nothing _
Or CellB Is Nothing Then
MsgBox "Design error with Object/CellA/CellB " & iCtr
Else
If Intersect(Target, Union(CellA, CellB)) Is Nothing Then
'do nothing
Else
If CellA.Value > CellB.Value Then
myColor = 11
ElseIf CellA.Value = CellB.Value Then
myColor = 13
Else
myColor = 10
End If
myShape.OLEFormat.Object.ShapeRange _
.Fill.ForeColor.SchemeColor = myColor
End If
End If
Next iCtr
End With

End Sub
Click to expand...
 
Back
Top