Excel新增行复制表单控件复选框及VBA行号引用优化问询

1. 在新增行宏中调用绑定复选框的宏 #

直接在插入行的语句后添加Link_CheckBoxes调用即可，修改后的代码如下：

Sub Add_Row_Pepperoni()
    Rows(7).Insert , xlFormatFromLeftOrAbove
    ' 调用复选框绑定宏
    Link_CheckBoxes
End Sub

Sub Add_Row_Pineapple()
    Rows(13).Insert , xlFormatFromLeftOrAbove
    ' 调用复选框绑定宏
    Link_CheckBoxes
End Sub

2. 解决固定行号失效的问题 #

直接用数字行号的核心问题是：插入行后原目标行的行号会自动递增（比如在第7行上方插入一行后，原来的第7行会变成第8行），导致下次运行宏时定位错误。推荐两种可靠的定位方式：

方式一：通过标题文本定位行 #

假设你的标题文本是固定的（比如"Pepperoni区域标题"、"Pineapple区域标题"），用Cells.Find方法精准定位标题行，修改后的代码示例：

Sub Add_Row_Pepperoni()
    Dim titleRow As Range
    ' 根据实际标题文本修改What参数
    Set titleRow = ActiveSheet.Cells.Find(What:="Pepperoni区域标题", _
                                        LookIn:=xlValues, _
                                        LookAt:=xlWhole)
                                        
    If titleRow Is Nothing Then
        MsgBox "未找到Pepperoni区域的标题行"
        Exit Sub
    End If
    
    ' 示例：在标题行下方插入新行，可根据需求改为titleRow.Row（标题前插入）
    Rows(titleRow.Row + 1).Insert , xlFormatFromLeftOrAbove
    Link_CheckBoxes
End Sub

Sub Add_Row_Pineapple()
    Dim titleRow As Range
    Set titleRow = ActiveSheet.Cells.Find(What:="Pineapple区域标题", _
                                        LookIn:=xlValues, _
                                        LookAt:=xlWhole)
                                        
    If titleRow Is Nothing Then
        MsgBox "未找到Pineapple区域的标题行"
        Exit Sub
    End If
    
    Rows(titleRow.Row + 1).Insert , xlFormatFromLeftOrAbove
    Link_CheckBoxes
End Sub

方式二：用命名区域标记标题行 #

1. 在Excel界面中，选中目标标题行（比如Pepperoni的标题行），在左上角名称框输入Pepperoni_Title回车完成命名；同理给Pineapple的标题行命名为Pineapple_Title。
2. 修改宏代码，通过命名区域定位：

Sub Add_Row_Pepperoni()
    Dim titleRow As Range
    On Error Resume Next
    Set titleRow = ActiveSheet.Range("Pepperoni_Title")
    On Error GoTo 0
    
    If titleRow Is Nothing Then
        MsgBox "未找到Pepperoni_Title命名区域"
        Exit Sub
    End If
    
    Rows(titleRow.Row + 1).Insert , xlFormatFromLeftOrAbove
    Link_CheckBoxes
End Sub

Sub Add_Row_Pineapple()
    Dim titleRow As Range
    On Error Resume Next
    Set titleRow = ActiveSheet.Range("Pineapple_Title")
    On Error GoTo 0
    
    If titleRow Is Nothing Then
        MsgBox "未找到Pineapple_Title命名区域"
        Exit Sub
    End If
    
    Rows(titleRow.Row + 1).Insert , xlFormatFromLeftOrAbove
    Link_CheckBoxes
End Sub

3. 补充：复制复选框到新行 #

默认的Rows.Insert不会复制单元格上的复选框控件，需要手动添加复制逻辑。假设复选框在第2列（B列），修改后的代码示例（以标题文本定位为例）：

Sub Add_Row_Pepperoni()
    Dim titleRow As Range
    Dim insertRowNum As Long
    Dim targetCol As Integer
    targetCol = 2 ' 复选框所在的列号，根据实际修改
    
    Set titleRow = ActiveSheet.Cells.Find(What:="Pepperoni区域标题", _
                                        LookIn:=xlValues, _
                                        LookAt:=xlWhole)
                                        
    If titleRow Is Nothing Then
        MsgBox "未找到Pepperoni区域的标题行"
        Exit Sub
    End If
    
    insertRowNum = titleRow.Row + 1
    Rows(insertRowNum).Insert , xlFormatFromLeftOrAbove
    
    ' 复制上一行的复选框到新行
    Dim prevChk As CheckBox
    For Each prevChk In ActiveSheet.CheckBoxes
        ' 匹配上一行目标列的复选框
        If prevChk.TopLeftCell.Row = insertRowNum - 1 And _
           prevChk.TopLeftCell.Column = targetCol Then
            prevChk.Copy
            ActiveSheet.Paste Destination:=Cells(insertRowNum, targetCol)
            ' 设置新复选框随单元格移动/调整大小
            With ActiveSheet.CheckBoxes(ActiveSheet.CheckBoxes.Count)
                .Placement = xlMoveAndSize
            End With
            Exit For
        End If
    Next prevChk
    
    Link_CheckBoxes
End Sub

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