Macro Buttons change colour when pressed

[Phill032]

Hi,
Looking for a solution to my Macro button (shape) problem.
I have the below code which will colour a depressed button.
Problem is this will only work for 1 button and i have 12 that i want it to work for.
The idea would be that the button stays depressed until another button is selected.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160704
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value = 1 Then
ActiveSheet.Shapes("Rounded Rectangle 4").Fill.ForeColor.RGB = vbRed
ElseIf Target.Value < 1 And Target.Value > 1 Then
ActiveSheet.Shapes("Rounded Rectangle 4").Fill.ForeColor.RGB = vbYellow
Else
ActiveSheet.Shapes("Rounded Rectangle 4").Fill.ForeColor.RGB = vbBlue
End If
End If
End Sub

 

[MickG]

Try code based on below:-
Add code for with extra Shapes as required
NB:-To add code Right click shape and select "Assign Macro"

[COLOR="Navy"]Sub[/COLOR] colshp()
[COLOR="Navy"]Dim[/COLOR] shp [COLOR="Navy"]As[/COLOR] Shape
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] shp [COLOR="Navy"]In[/COLOR] ActiveSheet.Shapes
  If shp.Type = 1 Then '[COLOR="Green"][B]msoShapeRoundedRectangle Then[/B][/COLOR]
    [COLOR="Navy"]If[/COLOR] Application.Caller = shp.Name [COLOR="Navy"]Then[/COLOR]
        shp.Fill.ForeColor.SchemeColor = 3
     [COLOR="Navy"]Else[/COLOR]
        shp.Fill.ForeColor.SchemeColor = 4
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle1_Click()
colshp
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle2_Click()
colshp
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle3_Click()
colshp
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle4_Click()
colshp
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Phill032]

Works perfect, THANYOU

 

[Phill032]

So although the above code works perfectly, is there a way of making it work for sets or groups of buttons?
eg i have 3 seperate groups of buttons that will have 1 button in each group highlighted which will
identify the data that is shown.

 

[MickG]

Try something based on below:-
NB:- The code show 2 sets of 3 shapes !!
NB:- I found it is better to do a "Assign Macro" for each shape before you right Click and "Group" them.
Sometimes with these shapes you get a "Cannot find "Macro" or similar problems.

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle9_Click()
GetCol
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle10_Click()
GetCol
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle8_Click()
GetCol
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle25_Click()
GetCol
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle26_Click()
GetCol
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] RoundedRectangle27_Click()
GetCol
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Sub[/COLOR] GetCol()
[COLOR="Navy"]Dim[/COLOR] Shp [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] pShp [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] pShp = ActiveSheet.Shapes(Application.Caller).ParentGroup
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Shp [COLOR="Navy"]In[/COLOR] pShp.GroupItems
  [COLOR="Navy"]If[/COLOR] Shp.Type = 1 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Application.Caller = Shp.Name [COLOR="Navy"]Then[/COLOR]
        Shp.Fill.ForeColor.SchemeColor = 3
     [COLOR="Navy"]Else[/COLOR]
        Shp.Fill.ForeColor.SchemeColor = 4
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Phill032]

Yep that works awesome!, Thanks Mick

 

[MickG]

You're welcome