加快VBA中的按鈕格式化

我有下面的代碼，將所有按鈕（有 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```

uj5u.com熱心網友回復：

突出顯示單擊的形狀

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

uj5u.com熱心網友回復：

我懷疑這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

uj5u.com熱心網友回復：

這是我最終使用的代碼

'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

標籤：vba按钮格式化美学

上一篇：有沒有辦法按名稱過濾VBA用戶表單的串列框專案？

下一篇：使用.left和.offset查找