加速 VBA 中的按钮格式化

Question

我有下面的代码，将所有按钮（有 10 个）着色为灰色，以清除任何先前着色的按钮，然后将所选按钮着色为蓝色。基本上充当当前选择哪个按钮的指示器。我注意到代码现在需要一些时间才能运行这个修饰性的添加，我想知道是否有任何方法可以重写它以运行得更快？

感谢您的帮助，如果我可以提供更多详细信息，请告诉我

'
' 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```

Answer 1

突出显示单击的形状

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

Answer 2

我怀疑

Select

正在减慢这个过程，而且根本没有必要。通常，宏记录器创建的代码需要简化，尤其是永远不需要select某些东西。

我创建了一个包含近 100 个形状的工作表，并且以下代码可以立即运行（我的电脑已经有 6 年历史了……）。它循环遍历工作表的所有形状，通过测试形状的名称来检查形状是否应该着色。该检查被外包给一个私有函数，以使代码更具可读性 - 只需调整那里的 if 语句即可。如果你想给纸张的所有形状着色，你可以让函数在任何情况下返回 True，不需要检查名称。

在我的版本中，例程使用

Application.Caller

来查找单击以将其涂成蓝色的形状 - 因此您可以对所有形状使用相同的例程。

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

Answer 3

这是我最终使用的代码

'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