Excel添加复选框、批量添加

Excel添加复选框
office版本：专业增强版2021

打开开发工具

文件→选项→自定义功能区→主选项卡勾选开发工具

添加复选框

开发工具→插入→选中表单控件：复选框

使用VBA批量添加复选框

开发工具→宏→输入方法名→点击创建→输入代码→切回Excel文件→选择执行范围→宏执行

代码如下：

Sub 复选框()
  
    Application.ScreenUpdating = False
  
    Dim rng As Range
    Dim topLeftCell As Range
    Dim chkBoxTop As Double
    Dim chkBoxLeft As Double
    Dim chkBoxWidth As Double
    Dim chkBoxHeight As Double
      
    For Each rng In Selection
        ' 获取rng的左上角单元格
        Set topLeftCell = rng.Cells(1, 1)
          
        ' 计算复选框的位置和大小
        chkBoxTop = topLeftCell.Top + (rng.Height / 2) - (topLeftCell.RowHeight / 2)
        chkBoxLeft = topLeftCell.Left + (rng.Width / 2) - (topLeftCell.Width / 2)
        chkBoxWidth = rng.Width / 2
        chkBoxHeight = rng.Height / 2
          
        ' 检查rng的值是否为"TRUE"
        If rng.Value = True Then
            With Sheet1.CheckBoxes.Add(Top:=chkBoxTop, Left:=chkBoxLeft, Width:=chkBoxWidth, Height:=chkBoxHeigh)
                .Value = xlOn
                .Caption = ""
            rng.Value = Null
            End With
        Else
            With Sheet1.CheckBoxes.Add(Top:=chkBoxTop, Left:=chkBoxLeft, Width:=chkBoxWidth, Height:=chkBoxHeight)
                .Value = xlOff
                .Caption = ""
            rng.Value = Null
            End With
        End If
    Next rng
      
    Application.ScreenUpdating = True
End Sub

执行成功后的效果如下：

目前存在问题：复选框的位置不够居中。