VBA中为循环创建的形状数组添加Yes/No切换按钮功能

方法一：类模块绑定事件（推荐，批量管理高效） #

1. 创建类模块 #

打开VBA编辑器（Alt+F11），右键插入「类模块」，命名为clsShapeClick，然后粘贴以下代码：

Public WithEvents shp As Shape
Private currentState As Integer ' 0=空白灰色, 1=Yes绿色, 2=No红色

Private Sub shp_Click()
    currentState = currentState + 1
    If currentState > 3 Then currentState = 1 ' 循环切换状态
    
    With shp
        Select Case currentState
            Case 1
                .TextFrame2.TextRange.Text = "Yes"
                .Fill.ForeColor.RGB = RGB(0, 255, 0) ' 绿色填充
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' 白色文字
            Case 2
                .TextFrame2.TextRange.Text = "No"
                .Fill.ForeColor.RGB = RGB(255, 0, 0) ' 红色填充
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' 白色文字
            Case 3
                .TextFrame2.TextRange.Text = ""
                .Fill.ForeColor.RGB = RGB(192, 192, 192) ' 灰色填充
                currentState = 0 ' 重置初始状态
        End Select
    End With
End Sub

2. 批量生成形状并绑定类 #

插入「标准模块」，粘贴以下代码：

Dim shapeCollection As New Collection ' 全局集合，防止类实例被回收

Sub CreateShapesWithClickEvent()
    Dim i As Integer, j As Integer
    Dim newShape As Shape
    Dim shapeClass As clsShapeClick
    
    ' 可选：清除现有矩形形状，避免重复创建
    For Each newShape In ActiveSheet.Shapes
        If newShape.Type = msoShapeRectangle Then newShape.Delete
    Next newShape
    
    ' 循环创建形状并绑定事件
    For i = 1 To 3
        For j = 2 To 17
            Set newShape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
                Cells(j, i).Left, Cells(j, i).Top, Cells(j, i).Width, Cells(j, i).Height)
            
            ' 初始化形状样式
            With newShape
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                .TextFrame2.TextRange.Text = ""
                .Name = "Rect_" & i & "_" & j ' 命名形状方便识别
            End With
            
            ' 绑定点击事件到类
            Set shapeClass = New clsShapeClick
            Set shapeClass.shp = newShape
            shapeCollection.Add shapeClass
        Next j
    Next i
End Sub

方法二：通用宏绑定（简单场景适用） #

如果不想用类模块，可通过指定通用宏实现，用形状的Tag属性存储状态：

1. 创建通用点击处理宏 #

在标准模块中粘贴：

Sub ShapeClickHandler()
    Dim targetShp As Shape
    Dim currentState As Integer
    
    Set targetShp = ActiveSheet.Shapes(Application.Caller)
    
    ' 读取当前状态，默认0
    currentState = IIf(targetShp.Tag = "", 0, CInt(targetShp.Tag))
    currentState = currentState + 1
    
    With targetShp
        Select Case currentState
            Case 1
                .TextFrame2.TextRange.Text = "Yes"
                .Fill.ForeColor.RGB = RGB(0, 255, 0)
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
                .Tag = "1"
            Case 2
                .TextFrame2.TextRange.Text = "No"
                .Fill.ForeColor.RGB = RGB(255, 0, 0)
                .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
                .Tag = "2"
            Case 3
                .TextFrame2.TextRange.Text = ""
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                .Tag = "0"
                currentState = 0
        End Select
    End With
End Sub

2. 修改形状生成代码 #

替换原创建形状的代码为：

Sub CreateShapesWithMacro()
    Dim i As Integer, j As Integer
    Dim newShape As Shape
    
    ' 可选：清除现有矩形
    For Each newShape In ActiveSheet.Shapes
        If newShape.Type = msoShapeRectangle Then newShape.Delete
    Next newShape
    
    For i = 1 To 3
        For j = 2 To 17
            Set newShape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
                Cells(j, i).Left, Cells(j, i).Top, Cells(j, i).Width, Cells(j, i).Height)
            
            ' 初始化并绑定宏
            With newShape
                .Fill.ForeColor.RGB = RGB(192, 192, 192)
                .TextFrame2.TextRange.Text = ""
                .Name = "Rect_" & i & "_" & j
                .OnAction = "ShapeClickHandler" ' 指定点击触发的宏
                .Tag = "0" ' 初始化状态
            End With
        Next j
    Next i
End Sub

注意事项 #

• 类模块方法的状态存储在类实例中，不会被误改，适合大量形状管理
• 宏方法依赖Tag属性，需确保该属性不被其他代码修改
• 可将ActiveSheet替换为具体工作表名（如Sheet1），避免依赖激活状态

内容的提问来源于stack exchange，提问作者RBRN1231