VBA批量复制公式至新增行失效，仅首个位置生效问题求助

我编写了一段VBA代码，可根据A列中的“add line”标记在其下方插入行（例如A10单元格为“add line”时，会在A11插入行），并将原行E:H列的公式复制粘贴到新增行中。但代码仅对第一个“add line”位置生效——当A10、A13、A20均为“add line”时，仅A11能成功复制A10的公式，A14、A21未按预期复制对应A13、A20的公式。

以下是我编写的代码：

Sub PasteFormulasBelowAddLine()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim addLineRows() As Long
    Dim addLineCount As Long
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Input Sheet_wo_Main Sum Lin (3)")
    
    ' Find the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    
    ' Initialize variables
    addLineCount = 0
    
    ' Loop through column A to find "add line" and store row numbers in array
    For i = 1 To lastRow
        If ws.Cells(i, "A").Value = "add line" Then
            addLineCount = addLineCount + 1
            ReDim Preserve addLineRows(1 To addLineCount)
            addLineRows(addLineCount) = i
        End If
    Next i
    
    ' Paste formulas in rows below "add line"
    For i = 1 To addLineCount
        ' Check if the row below "add line" exists and is not empty
        If addLineRows(i) < lastRow Then
            ' Copy formulas from the row containing "add line"
            ws.Range(ws.Cells(addLineRows(i), "E"), ws.Cells(addLineRows(i), "H")).Copy
            ' Paste formulas into the row below
            ws.Range(ws.Cells(addLineRows(i) + 1, "E"), ws.Cells(addLineRows(i) + 1, "H")).PasteSpecial Paste:=xlPasteFormulas
            Application.CutCopyMode = False ' Clear clipboard
        End If
    Next i
End Sub

错误原因 #

问题出在行号偏移：你先遍历收集了所有"add line"的原始行号，但当你在第一个"add line"下方插入行后，表格中后续的行号都会向下偏移1位（比如原来的A13会变成A14），但你后续仍使用最初收集的旧行号（13）去操作，自然找不到正确的目标行，导致公式复制失败。

修正后的代码 #

改为从下往上遍历行，这样插入行不会影响还未处理的行号（下方的行处理完后，上方的行号不会被偏移），同时无需预先收集行号数组，直接遍历处理：

Sub PasteFormulasBelowAddLine()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Input Sheet_wo_Main Sum Lin (3)")
    
    ' Find the last row in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 从下往上遍历，避免插入行导致的行号偏移问题
    For i = lastRow To 1 Step -1
        If ws.Cells(i, "A").Value = "add line" Then
            ' 在当前行下方插入新行
            ws.Rows(i + 1).Insert Shift:=xlDown
            ' 复制当前行E:H的公式到新行
            ws.Range(ws.Cells(i, "E"), ws.Cells(i, "H")).Copy
            ws.Range(ws.Cells(i + 1, "E"), ws.Cells(i + 1, "H")).PasteSpecial Paste:=xlPasteFormulas
            Application.CutCopyMode = False ' 清除剪贴板
        End If
    Next i
End Sub

示例说明 #

• 初始表格：A列存在多个"add line"标记，对应行的E:H列包含公式
• 修正后结果：所有"add line"标记下方的新增行，都会复制对应原行的E:H列公式

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