VBA脚本问题：删除指定行后仅复制公式插入行至1000行

问题描述 #

我编写了一段VBA脚本，用于根据每行的状态单元格删除对应行，随后在工作表倒数第二行插入与删除行数相同的新行。但复制公式时遇到问题：当前代码会复制所有内容（包括输入值），我希望仅复制公式。

背景说明 #

为控制文件大小，公式原本延伸至第1000行。删除行后，引用这些单元格的公式范围会从例如A10:A1000变为A10:A999，最终文件会过小，因此需要插入行使公式始终延伸至第1000行。

现有代码 #

Sub Delete_range_ws2()

Dim i            As Long
Dim TexttoFind   As String
Dim ws2 As Worksheet
Set ws2 = Sheets("2. and 6. WD Input vs GL")

TexttoFind = "Ready to Delete" ' <-- Use a variable, this is easy to modify later

'Step 1: Find any row that has "Ready to Delete" and and delete the entir row.
For i = Range("CZ5000").End(xlUp).Row To 1 Step -1     'Find Last Row. NOTE, I put the range at 5x the 1000 row limit. I'm sure there is a better way, but I didn't have time to figure it out.
    If ws2.Range("CZ" & i) = TexttoFind Then            'Look in last row for "Ready to Delete"
        ws2.Rows(i).Delete                              'If found, delete row
    End If
    Range("A3").Select  'Bring user's view back to top left corner of sheet
Next

Dim lrow As Integer
Dim m As Integer
Dim n As Integer

'Step 2:  Now that we deleted rows, we need to add blank rows back into the sheet and copy formulas down
         'Why? Trying to make sure formulas continue to row 1000
With ws2
    lrow = Cells(Rows.Count, "A").End(xlUp).Row  'Now that rows have been deleted, find the new last row
    m = Cells(Rows.Count, "A").End(xlUp).Row - 1 'Find Second to last row
    n = 1000 - lrow       'Number of rows that were deleted
    
    If lrow = 1000 Then     'If true, then the above logic didn't delete any rows.
    Else
                            'If not True, then find the last row and insert the number of rows that were deleted
    ws2.Rows(lrow & ":" & m + n).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            'Now that rows were inserted, we need to copy down
                            'formulas all the way to the limit of row 1000
                            'This is not perfect, it just goes back up the rows and finds a row to copy
                            'formulas down. THis WILL NOT Copy text inputs
    ws2.Rows(m - n).Copy
    ws2.Rows(m - n & ":1000").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone
           
    End If                  'Ends the IF Statement
    ws2.Range("A3").Select  'Bring user's view back to top left corner of sheet
End With                    'Ends the With Statement
    
End Sub

解决方案及修改后的代码 #

针对你的问题，主要需要优化行索引计算、确保仅复制公式，同时提升代码准确性和效率：

Sub Delete_range_ws2()
    Dim i As Long
    Dim TexttoFind As String
    Dim ws2 As Worksheet
    Set ws2 = Sheets("2. and 6. WD Input vs GL")
    
    TexttoFind = "Ready to Delete"
    
    ' Step1: 删除状态为"Ready to Delete"的行
    With ws2
        ' 动态获取CZ列最后一行，替代硬编码的CZ5000
        Dim lastRowCZ As Long
        lastRowCZ = .Cells(.Rows.Count, "CZ").End(xlUp).Row
        
        ' 从下往上遍历，避免删除行后索引混乱
        For i = lastRowCZ To 1 Step -1
            If .Range("CZ" & i).Value = TexttoFind Then
                .Rows(i).Delete
            End If
        Next i
    End With
    
    ' Step2: 插入行并仅复制公式到第1000行
    With ws2
        Dim currentLastRow As Long
        currentLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Dim rowsToAdd As Long
        rowsToAdd = 1000 - currentLastRow
        
        If rowsToAdd > 0 Then
            ' 插入需要补充的行数
            .Rows(currentLastRow & ":" & currentLastRow + rowsToAdd - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            
            ' 取插入前的倒数第二行作为公式源（确保该行有公式）
            Dim sourceRow As Long
            sourceRow = currentLastRow - 1
            
            ' 仅复制公式到目标范围
            .Rows(sourceRow).Copy
            .Rows(sourceRow & ":1000").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone
            
            ' 清除剪贴板，避免干扰后续操作
            Application.CutCopyMode = False
        End If
        
        ' 回到指定视图位置
        .Range("A3").Activate
    End With
End Sub

关键修改说明 #

• 动态获取最后一行：替换硬编码的Range("CZ5000")，改为.Cells(.Rows.Count, "CZ").End(xlUp).Row，准确获取CZ列的有效最后一行
• 修正插入行范围：计算需要插入的行数后，从当前最后一行开始插入对应数量的行，避免行索引错误
• 明确公式源行：指定插入前的倒数第二行作为公式复制源，确保复制的是正确的公式行
• 强制仅复制公式：通过xlPasteFormulas参数，确保粘贴时只保留公式，不会带入输入值
• 优化代码效率：移除不必要的Select操作，使用With语句限定工作表范围，避免跨表错误

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