Assign numbers to shapes excel 2007

**mammagamma** · 07-02-2012, 06:34 AM

Good morning all,
I have been searching the net for a way of assigning numbers to 10 shapes that I will be using as buttons. I would like them to behave like 10 option buttons (form controls buttons), when the first shape is clicked I would get the number 1 in a specific cell (link cell). When the second button is clicked, I would get number 2 and so on. The selected shape would also need to change color until the next button is selected.

many thanks

**MickG** · 07-02-2012, 07:55 AM

This code returns the number of the shape in "A1" and turns the selected shape "Red" and the others "Green"
Paste the first code in each of the codes for the ten shapes as below

Sub Rectangle10_Click()
Call shps(Application.Caller)
End Sub

Place this code in a seperate Basic "Module"

Sub shps(Nam)
Dim Shp As Shape
Range("A1") = Split(Nam, " ")(1)
For Each Shp In ActiveSheet.Shapes
    If Shp.Name = Nam Then
        Shp.Fill.ForeColor.SchemeColor = 10
    Else
        Shp.Fill.ForeColor.SchemeColor = 3
    End If
Next Shp
End Sub

Regards Mick

**mammagamma** · 07-02-2012, 12:16 PM

Hello and thanks you for your help.
I think I managed to put it into action but I must have not followed the right procedure as I get the word "rectangle" in cell a1. I also have other shapes in the sheet and they all turn the colour of the buttons. Any suggestion?

**MickG** · 07-02-2012, 12:55 PM

You could try this line below to get the number.
The code seems to think theres an extra space there. I assumed the shape names where like "Rectangels 2" etc.
Nb:- If there is an extra space you could just changing the (1) at the end to (2).

Other shapes:-
Are the other shapes rectangles, or other shapes types, as you need to differentiate between the ones you wish to colour and the rest.
Let me know and I'll alter the code !!

Range("A1") = Split(Trim(Nam), " ")(1)

**mammagamma** · 07-02-2012, 02:36 PM

Changing the number worked although I needed the cell to count from one. I get the shape label number, I thinkCapture2.PNG

In Total I have 30 identical shapes, 2 groups of 10 and the rest are of different sizes. Ideally I would like to have 2 groups work indipendently so as to produce numbers from 1 to 10 in one cell and 1 to 10 in another cell

**MickG** · 07-03-2012, 06:00 AM

What you need to do is form a "Group" of each set of shapes.
First to give each shape a unique number alter the basic code for each of the rectangles in each group as below.
Notice the "1" after "Application caller" , this is the first number of the set and in my code will appear in "A1"

Sub Rectangle1_Click()
Call shps(Application.Caller, 1)
End Sub

Alter the code as above, Change the numbers as required.
When you have done that alter the lines in the "Module " code a shown in Red.

Sub shps(Nam, n)
Dim Shp As Shape
Range("A1") = n
For Each Shp In ActiveSheet.Shapes("Group 15").GroupItems   
 If Shp.Name = Nam Then

To form a Group of shapes, hold down the "Ctrl" key and select each Shape in the Group.
On the last shape after selecting, Right Click and select "Grouping", "Group" .
The shapes shoud be part of a Group. Look to the formula Box for its name.
In the Module code change the Group 15" to the new shape name.
Try the code out.
Be careful when forming a Group, I found that Shapes close to the group but not wanted in the group somehow got seleted. so keep those temporarily away from the group.
Regards Mick

**mammagamma** · 07-03-2012, 06:18 PM

I also tried leaving no space between name and number:
Case "Group13"
Select Case nam
Case "Rectangle1": [A1] = 1
Case "Rectangle2": [A1] = 2
Case "Rectangle3": [A1] = 3
Case "Rectangle4": [A1] = 4

**mammagamma** · 07-04-2012, 04:28 AM

If ActiveSheet.Shapes(nam).OLEFormat.Object.Name = oShape.Name Then

I get nam=error 2023 (hovering on (nam)

**MickG** · 07-04-2012, 06:58 AM

Have a look at this Example:-

**mammagamma** · 07-04-2012, 07:29 AM

Not working. Bet the excel file format.... Running your .xls in compatibility mode on Excel 2007, no luck. Converted in all possible ways, no luck. Still trying....