Colour Coded Shapes

[brrahimah]

Hi,

I am in dire need of help.
Currently I have created 3 basic shapes, oval, to represent red,
yellow and green respectively. I have also assigned a macro to each
shapes so that when I clicked on it, the colour will change
accordingly. My 3 shapes are in one cell. My problem is that I have at
least 30 rows and each row has 3 columns of these shapes.. Total is 90
oval shapes... numbering from 1 to 90... In order to create successful
macro, I have to create 90 macros (because of the oval shapes
numbering). Is there any shortcut whereby I can create only 3 macros
and assign it accordingly w/o having it linked to other shapes.

Appreciate all help given...

 

[Tim Williams]

Give your shapes a meaningful name such as "oval_001", "oval_002" etc.

Link them all to the same macro and in the code use Application.Caller to
find which one was clicked.

Tim

 

[Peter T]

Try the following in a test sheet

Sub makeOvals()
Dim r As Long, c As Long
Dim ovl As Oval
Dim shp As Shape
Dim nClr As Long
Dim sName As String

ActiveSheet.Ovals.Delete

For r = 1 To 30
For c = 1 To 3
With ActiveSheet.Cells(r + 1, c + 1)
Set shp = ActiveSheet.Shapes.AddShape(msoShapeOval, .Left +
0.75, .Top + 0.75, .Height - 1.5, .Height - 1.5)
End With

Select Case c
Case 1
sName = "Red_"
nClr = RGB(255, 0, 0)
Case 2
sName = "Amber_"
nClr = RGB(255, 204, 0)
Case 3
sName = "Green_"
nClr = RGB(0, 235, 0)
End Select

shp.Name = sName & Right$("0" & r, 2) & "_" & c
shp.Fill.ForeColor.RGB = nClr
shp.Line.Visible = msoFalse
shp.Fill.Visible = msoTrue
shp.OnAction = "TrafficLights"
Next
Next

Application.ScreenUpdating = True

End Sub

Sub TrafficLights()
Dim nRow As Long, nCol As Long
Dim sCaller As String
Dim arrCaller
sCaller = Application.Caller
arrCaller = Split(sCaller, "_")
With ActiveSheet.Shapes(sCaller).TopLeftCell
nRow = .Row
nCol = .Column
End With

Select Case arrCaller(0)
Case "Red"
'do stuff with arrCaller(1) & arrCaller(2)
' and/or nRow & nCol
Case "Amber"
' code
Case "Green"
' code
End Select

MsgBox arrCaller(0) & vbCr & Val(arrCaller(1)) & vbCr &
Val(arrCaller(2)) _
& vbCr & nRow & vbCr & nCol, , sCaller

End Sub


The above assigns all to just the one macro, but you could easily adapt to
use three.
Dim sOnAction as string

Select Case c
case 1: sOnAction = "myRedMacro"
etc

shp.OnAction = sOnAction

Regards,
Peter T