求Excel VBA宏：按指定间隔复制行值至目标行（不移位）

需求说明 #

需编写Excel宏，从指定工作表第7行开始，每隔6行复制该行的公式计算值，粘贴至同一工作表从第5行开始的每隔6行（即第7行值贴到第5行、第13行贴到第11行，直至最后有效行），要求不移动或删除含公式的源行。

现有代码问题 #

用户无编程基础，神经网络生成的代码会导致源行下移，不符合需求，代码如下：

Sub Copy_And_Insert_Rows()
    Dim i As Integer
    Dim lastRow As Integer

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 6 To lastRow Step 6
        Rows(i).Copy
        Rows(i - 2).Insert Shift:=xlDown
    Next i

    Application.CutCopyMode = False
End Sub

这段代码通过插入行实现，会导致所有源行下移，违背了“不移动源行”的核心要求。

用户手动编写了适配3行的示例代码，需要改写为适配数千行的通用代码：

Sub Copy_And_Insert_Rows()
Range("d7:crg7").Copy
Range("d5:crg5").PasteSpecial xlPasteValues
Range("d13:crg13").Copy
Range("d11:crg11").PasteSpecial xlPasteValues
Range("d19:crg19").Copy
Range("d17:crg17").PasteSpecial xlPasteValues
End Sub

通用解决方案代码 #

以下是适配任意行数的通用宏代码，严格遵循需求，不会移动或删除源行：

Sub CopyFormulaValuesToTargetRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sourceRow As Long
    Dim targetRow As Long
    Dim dataRange As Range
    
    ' 指定操作的工作表，替换为你的工作表名称
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 获取数据最后一行（以A列判断，可修改为实际列）
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 从第7行开始，每隔6行处理一次
    For sourceRow = 7 To lastRow Step 6
        targetRow = sourceRow - 2 ' 目标行是源行上移2行
        
        ' 复制D到CRG列的公式计算值
        Set dataRange = ws.Range("D" & sourceRow & ":CRG" & sourceRow)
        dataRange.Copy
        ws.Range("D" & targetRow & ":CRG" & targetRow).PasteSpecial Paste:=xlPasteValues
        
        ' 清除复制状态
        Application.CutCopyMode = False
    Next sourceRow
    
    MsgBox "批量复制完成！"
End Sub

代码调整说明 #

• 工作表名称：将ThisWorkbook.Worksheets("Sheet1")中的Sheet1改为你实际要操作的工作表名称。
• 最后一行判断列：如果数据的最后一行不是由A列标识，修改ws.Cells(ws.Rows.Count, "A")中的"A"为对应列号（如"B"、"C"）。
• 列范围：若需调整复制的列范围，修改Range("D" & sourceRow & ":CRG" & sourceRow)中的列标识即可。

内容的提问来源于stack exchange，提问作者федор крючков