加速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正在减慢进程，根本没有必要。通常，宏记录器正在创建的代码需要精简，尤其是从不需要选择内容。

我创建了一张有近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