Macro Buttons change colour when pressed

Phill032

New Member
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

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

Code:
[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
 
Last edited:

Phill032

New Member
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

MrExcel MVP
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.
Code:
[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
 
Last edited:

Some videos you may like

This Week's Hot Topics

  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • find many based on a certain criteria
    good evening, I hope someone can help me? I have a workbook sheet 2 contains lots of data.... I would like to be able to find anything on sheet...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
  • Text Format
    I have a sheet for user to keyin the data. The format of the data can be 451 / 1903, 0012 / 9908 or 00287 / 0099. The number after the "/" is...
  • Macro to copy values across rows and transposing them and add the user id
    [FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT][FONT=Calibri][SIZE=3][COLOR=#000000]Hi,[/COLOR][/SIZE][/FONT] [FONT=Times New...
Top