Excel工作表重叠复选框清理：保留单个的VB代码需求

以下是两种场景的VBA代码，分别处理表单控件复选框和ActiveX复选框，实现每个单元格仅保留一个复选框，删除其余重叠项：

表单控件复选框版本 #

适用于通过「开发工具→插入→表单控件」添加的复选框：

Sub RemoveDuplicateCheckboxes()
    Dim ws As Worksheet
    Dim cb As CheckBox
    Dim cellKey As String
    Dim cbDict As Object
    
    ' 指定目标工作表，可改为具体表名如Sheets("数据报表")
    Set ws = ActiveSheet
    ' 用字典记录每个单元格已存在的复选框
    Set cbDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历工作表中所有表单控件复选框
    For Each cb In ws.CheckBoxes
        ' 以复选框左上角所在单元格地址作为唯一标识
        cellKey = cb.TopLeftCell.Address
        
        If cbDict.exists(cellKey) Then
            ' 该单元格已有复选框，删除当前重复项
            cb.Delete
        Else
            ' 首次遇到该单元格的复选框，存入字典标记
            cbDict.Add cellKey, cb.Name
        End If
    Next cb
    
    ' 释放对象资源
    Set cbDict = Nothing
    Set ws = Nothing
    
    MsgBox "处理完成：已移除所有重叠复选框，每个单元格仅保留一个。", vbInformation
End Sub

ActiveX复选框版本 #

适用于通过「开发工具→插入→ActiveX控件」添加的复选框：

Sub RemoveDuplicateActiveXCheckboxes()
    Dim ws As Worksheet
    Dim oleObj As OLEObject
    Dim cellKey As String
    Dim cbDict As Object
    
    Set ws = ActiveSheet
    Set cbDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历工作表中所有OLE对象，仅处理复选框控件
    For Each oleObj In ws.OLEObjects
        If oleObj.progID = "Forms.CheckBox.1" Then
            cellKey = oleObj.TopLeftCell.Address
            
            If cbDict.exists(cellKey) Then
                oleObj.Delete
            Else
                cbDict.Add cellKey, oleObj.Name
            End If
        End If
    Next oleObj
    
    Set cbDict = Nothing
    Set ws = Nothing
    
    MsgBox "ActiveX复选框处理完成！", vbInformation
End Sub

使用步骤 #

1. 打开目标Excel文件，按Alt+F11打开VBA编辑器
2. 点击菜单栏「插入→模块」，将对应版本的代码粘贴到模块窗口中
3. 按F5运行宏，或回到Excel界面，通过「开发工具→宏」选择对应的宏执行

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