Speeding up button formatting in VBA

Question

I have the below code that colors all the buttons (there are 10) grey to clear any previously colored button, and then colors the button selected blue. Basically acting as an indicator of what button is currently selected. I noticed that the code now takes a moment to run with this cosmetic addition and I was wondering if there is any way to re-write this to run faster?

Thank you for your help and please let me know if I can provide any more detail

'
' all_days Macro

'change all buttons to grey first
      ActiveSheet.Shapes.Range(Array("Rectangle: Rounded Corners 17", _
        "Rectangle: Rounded Corners 12", "Rectangle: Rounded Corners 11")).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = -0.5
        .Transparency = 0
        .Solid
    End With
    
'change selected button to blue
     ActiveSheet.Shapes.Range(Array("Rectangle: Rounded Corners 12")).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = -0.25
        .Transparency = 0
        .Solid
    End With
    
    ActiveSheet.Range("$A$1:$X$740").AutoFilter Field:=12
    ActiveSheet.Range("$A$1:$X$100000").AutoFilter Field:=17
End Sub```

`TintAndShade` attribute is set to 0 by both selectors - is it needed? Same with `Transparency`, `Solid` and `Visible`. — STerliakov, Oct 25 '22 at 15:24
Thanks @SUTerliakov, I wrote this with the macro recorder so left it as is. They are not needed and after removed the code still works, but it is no faster. — RBRN1231, Oct 25 '22 at 15:53

score 2 · Answer 1 · answered Oct 25 '22 at 16:28

I suspect that the Select is slowing down the process, and it is not necessary at all. Usually the code that the macro recorder is creating needs to be streamlined, especially it is always never needed to select something.

I created a sheet with nearly 100 shapes and the following code runs rather instantly (and my PC is 6 years old...). It loops over all shapes of a worksheet, checks if the shape should be colored by testing the name of it. This check is outsourced to a private function to make the code more readable - simply adapt the if-statement there. And if you want to color all shapes of the sheets, you can let the function return True in any case, no need to check the names.

In my version, the routine uses Application.Caller to find the shape that was clicked to paint it with blue - therefore you can use the same routine for all shapes.

Sub shapes()
    Dim ws As Worksheet, sh As Shape
    Set ws = ActiveSheet
    
    For Each sh In ws.shapes
        If isButtonShape(sh) Then
            sh.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground2
        End If
    Next

    On Error Resume Next
    Set sh = Nothing
    Set sh = ws.shapes(Application.Caller)
    On Error GoTo 0
    If Not sh Is Nothing Then
        If isButtonShape(sh) Then
            sh.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
            sh.Fill.ForeColor.TintAndShade = 0
        End If
    End If
End Sub

Private Function isButtonShape(sh As Shape) As Boolean
    isButtonShape = (sh.Name = "Rectangle: Rounded Corners 17" _
                  Or sh.Name = "Rectangle: Rounded Corners 12" _
                  Or sh.Name = "Rectangle: Rounded Corners 11")
End Function

score 2 · Accepted Answer · answered Oct 25 '22 at 17:29

Highlight Clicked Shape

Sub HighlightClickedShape()
    
    Dim ShapeNames() As Variant
    ShapeNames = Array("Rectangle: Rounded Corners 17", _
        "Rectangle: Rounded Corners 12", "Rectangle: Rounded Corners 11")
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Dim shprg As ShapeRange: Set shprg = ws.shapes.Range(ShapeNames)
    
    ResetShapeRange shprg
    
    Dim shp As Shape
    On Error Resume Next
        Set shp = shprg(Application.Caller)
    On Error GoTo 0
    
    If shp Is Nothing Then
        MsgBox "This only works when clicking on one of the following shapes:" _
            & vbLf & vbLf & Join(ShapeNames, vbLf), vbCritical
        Exit Sub
    End If
    
    HighlightShape shp

End Sub

Sub ResetShapeRange(ByVal shprg As ShapeRange)
    With shprg.Fill.ForeColor
        .ObjectThemeColor = msoThemeColorBackground1
        .Brightness = -0.5
    End With
End Sub

Sub HighlightShape(ByVal shp As Shape)
    With shp.Fill.ForeColor
        .ObjectThemeColor = msoThemeColorAccent1
        .Brightness = -0.25
    End With
End Sub

Thank you @VBasic2008. I used the skeleton of your code for my purposes and this has made it much quicker. — RBRN1231, Oct 25 '22 at 18:26

score 1 · Answer 3 · answered Oct 25 '22 at 18:27

This is the code that I ended up using

'change all buttons to grey first
Dim shapenames() As Variant
Dim ws As Worksheet: Set ws = ActiveSheet

shapenames = Array("Rectangle: Rounded Corners 17", "Rectangle: Rounded Corners 12", "Rectangle: Rounded Corners 11")
     
Dim shprg As ShapeRange: Set shprg = ActiveSheet.shapes.Range(shapenames)
    
    With shprg.Fill.ForeColor
        .ObjectThemeColor = msoThemeColorBackground1
        .Brightness = -0.5
    End With
    
'change selected button to blue

Dim shapename() As Variant

shapename = Array("Rectangle: Rounded Corners 12")
     
Set shprg = ActiveSheet.shapes.Range(shapename)
    
    With shprg.Fill.ForeColor
        .ObjectThemeColor = msoThemeColorAccent1
    End With

Speeding up button formatting in VBA

3 Answers3

Highlight Clicked Shape