基于指定列“Start”值批量插行并复制公式的VBA代码优化需求

需求说明 #

• 用Application.InputBox让用户指定目标列
• 在该列所有值为“Start”的单元格下方，插入用户指定数量的新行
• 把“Start”所在行的公式复制到新插入的行里
• 补充场景：点击按钮触发代码、“Start”的数量和位置不固定但都在同一列、工作表名称不固定、每行的数据/公式宽度是动态的

现有代码的不足 #

Code 1 #

• 能让用户指定包含“Start”的列，但只能在每个“Start”行下方插1行
• 不会把“Start”行的公式复制到新行

Dim Rng As Range
    Dim WorkRng As Range
    On Error Resume Next
    
    xTitleId = "Enter the value"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    Set WorkRng = WorkRng.Columns(1)
    xLastRow = WorkRng.Rows.Count
    Application.ScreenUpdating = False
    For xRowIndex = xLastRow To 1 Step -1
        Set Rng = WorkRng.Range("A" & xRowIndex)
        If Rng.Value = "Start" Then
            Rng.Offset(1, 0).EntireRow.Insert Shift:=xlDown
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Code 2 #

• 能让用户指定插入行数和起始行，但没法识别“Start”值作为插入依据
• 不复制公式到新行

Dim iRow As Long
Dim iCount As Long
Dim i As Long
On Error Resume Next

iCount = Application.InputBox(Prompt:="How many rows you want to add?")
iRow = Application.InputBox _
  (Prompt:="After which row you want to add new rows? (Enter the row number")

For i = 1 To iCount
    Rows(iRow).EntireRow.Insert  
Next i

End Sub

改进后的完整VBA代码 #

基于Code 1扩展，整合了指定插入行数、复制公式的功能：

Sub InsertRowsAfterStartWithFormula()
    Dim targetCol As Range
    Dim insertRowCount As Long
    Dim lastRow As Long
    Dim currentRow As Long
    Dim startRow As Range
    Dim dataRange As Range
    Dim ws As Worksheet
    
    ' 关闭屏幕更新，让运行更流畅
    Application.ScreenUpdating = False
    
    ' 让用户选择目标列，点列标或者列里任意单元格都行
    On Error Resume Next
    Set targetCol = Application.InputBox("请选择目标列（点击列标或列内任意单元格）", "选择目标列", Type:=8)
    On Error GoTo 0
    If targetCol Is Nothing Then Exit Sub ' 用户取消就退出
    Set targetCol = targetCol.Columns(1) ' 确保只取一列
    Set ws = targetCol.Parent ' 获取当前操作的工作表
    
    ' 让用户输入要插入的行数，只接受正整数
    On Error Resume Next
    insertRowCount = Application.InputBox("请输入要在每个Start行下方插入的行数", "插入行数", Type:=1)
    On Error GoTo 0
    If insertRowCount <= 0 Then Exit Sub ' 输入无效或取消就退出
    
    ' 找到目标列的最后一行
    lastRow = ws.Cells(ws.Rows.Count, targetCol.Column).End(xlUp).Row
    
    ' 从下往上遍历，避免插入新行后打乱后续行的索引
    For currentRow = lastRow To 1 Step -1
        Set startRow = ws.Cells(currentRow, targetCol.Column)
        If startRow.Value = "Start" Then
            ' 插入指定数量的行
            startRow.Offset(1).Resize(insertRowCount).EntireRow.Insert Shift:=xlDown
            ' 复制Start行的公式和格式到新插入的行
            Set dataRange = ws.Rows(currentRow).EntireRow
            dataRange.Copy
            startRow.Offset(1).Resize(insertRowCount).EntireRow.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
            Application.CutCopyMode = False ' 清除复制状态，避免残留虚线框
        End If
    Next currentRow
    
    ' 恢复屏幕更新，弹出完成提示
    Application.ScreenUpdating = True
    MsgBox "操作完成！", vbInformation
End Sub

代码说明 #

• 自动适配任意工作表名称，不用手动改代码里的表名
• 输入校验：用户取消操作或者输入非正整数时直接退出，避免报错
• 从下往上遍历目标列，解决插入新行后行号偏移的问题
• 复制“Start”行的公式和数字格式，适配动态的行宽度（不管每行有多少列数据都能覆盖）
• 关闭屏幕更新提升运行速度，操作完成后给用户明确提示

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