VBA添加行按钮问题：需在Space/Total行上方插入新行

修改后的VBA代码 #

Sub RectangleRoundedCorners7_Click()
    Dim howMany As Long
    howMany = InputBox("How many rows?")
    If howMany < 1 Then Exit Sub ' 输入非正数时直接退出
    
    Dim targetRow As Range
    ' 从A列底部往上找包含"Space"的行
    Set targetRow = Columns("A").Find(What:="Space", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    ' 找不到Space就找Total
    If targetRow Is Nothing Then
        Set targetRow = Columns("A").Find(What:="Total", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        If targetRow Is Nothing Then
            MsgBox "没找到带Space或Total的行，检查下表格结构！"
            Exit Sub
        End If
    End If
    
    Dim i As Long
    Application.ScreenUpdating = False ' 关闭屏幕刷新，避免闪烁
    For i = 1 To howMany
        ' 复制第8行，插入到目标行上方
        Rows(8).Copy
        targetRow.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        ' 清空新行里的常量内容，保留公式和格式
        On Error Resume Next
        targetRow.Offset(-1).EntireRow.SpecialCells(xlCellTypeConstants).Value = ""
        On Error GoTo 0
        ' 更新目标行引用（插入后原目标行下移了一行）
        Set targetRow = targetRow.Offset(1)
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True ' 恢复屏幕刷新
End Sub

关键调整说明 #

• 定位目标行：从A列底部往上查找“Space”或“Total”，确保找到的是表格最底部的那一行，新行始终插在它上方
• 循环插入逻辑：每次插入后更新targetRow的位置，因为插入新行后原目标行会下移，这样下一次插入还是在正确的位置
• 优化体验：关闭屏幕刷新减少闪烁，增加输入合法性检查和未找到目标行的提示
• 保留原需求：依然复制第8行的格式和公式，清空新行的常量值

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