Excel宏复制粘贴错误：跨工作簿按名称复制数据异常

我需要将Template_National_Lookahead.xlsm的Sheet1中按名称分组的数据，复制到结构类似但名称顺序混乱的Book1.xlsm的Sheet1中。源文件Sheet1的数据结构如下：

我尝试了以下VBA代码：

Sub CopiarInformacionDependiendoDelNombre()

    Dim archivoA As Workbook
    Dim archivoB As Workbook
    Dim hojaA As Worksheet
    Dim hojaB As Worksheet
    Dim nombre As String
    Dim celdaA As Range
    Dim celdaB As Range
    Dim ultimaFilaA As Long
    Dim rangoDatos As Range
    Dim filaSubtotalA As Long
    
    Set archivoA = Workbooks.Open("C:\Users\JL\Desktop\TEST\Template_National_Lookahead.xlsm")
    Set archivoB = Workbooks.Open("C:\Users\JL\Desktop\TEST\Book1.xlsm")

    Set hojaA = archivoA.Sheets(1)
    Set hojaB = archivoB.Sheets(1)

    For Each celdaB In hojaB.Range("P2:P" & hojaB.Cells(hojaB.Rows.Count, "P").End(xlUp).Row)
        
        nombre = celdaB.Value
        
        Set celdaA = hojaA.Range("B2:B" & hojaA.Cells(hojaA.Rows.Count, "B").End(xlUp).Row).Find(nombre, LookIn:=xlValues)
        
        If Not celdaA Is Nothing Then
            filaSubtotalA = hojaA.Range(celdaA.Offset(1, 1), hojaA.Cells(hojaA.Rows.Count, celdaA.Column + 1)).Find("Subtotal", LookIn:=xlValues).Row
            
            Set rangoDatos = hojaA.Range(celdaA.Offset(1, 1), hojaA.Cells(filaSubtotalA - 1, celdaA.Column + 2))
            
            rangoDatos.Copy
            
            Set celdaB = hojaB.Range("P2:P" & hojaB.Cells(hojaB.Rows.Count, "P").End(xlUp).Row).Find(nombre, LookIn:=xlValues)
            If Not celdaB Is Nothing Then
                celdaB.Offset(1, 1).PasteSpecial Paste:=xlPasteValues
            End If
        End If
        
    Next celdaB

    archivoB.Save
    archivoA.Save

    MsgBox "Proceso completado", vbInformation

End Sub

但执行后出现两个问题：

1. 数据粘贴错位，结果如下：

2. 重复粘贴问题：比如粘贴Name2的数据后，会再次将Name1的11、12、13、14行数据粘贴到同一位置，处理Name3时也会重复此问题。

问题排查与修正 #

核心问题分析

1. 循环变量被重写：在For Each celdaB循环内部，执行Set celdaB = hojaB.Range(...).Find(...)，直接修改了循环迭代器变量，导致遍历逻辑混乱，出现重复粘贴。
2. Subtotal查找范围错误：原代码限定在celdaA.Offset(1,1)到列尾的范围查找Subtotal，可能因列内其他Subtotal干扰或范围限制找不到正确行，导致复制的数据范围错误。
3. 粘贴位置未处理旧数据：直接从名称行偏移一行粘贴，未清空目标位置的旧数据，导致新旧数据重叠错位。

修正后的代码

Sub CopiarInformacionDependiendoDelNombre()

    Dim archivoA As Workbook
    Dim archivoB As Workbook
    Dim hojaA As Worksheet
    Dim hojaB As Worksheet
    Dim nombre As String
    Dim celdaA As Range
    Dim celdaB As Range
    Dim rangoDatos As Range
    Dim filaSubtotalA As Long
    Dim filaDestino As Range
    Dim ultimaFilaDestino As Long
    
    ' 打开工作簿
    Set archivoA = Workbooks.Open("C:\Users\JL\Desktop\TEST\Template_National_Lookahead.xlsm")
    Set archivoB = Workbooks.Open("C:\Users\JL\Desktop\TEST\Book1.xlsm")

    Set hojaA = archivoA.Sheets(1)
    Set hojaB = archivoB.Sheets(1)

    ' 遍历目标文件中的名称列（P列）
    For Each celdaB In hojaB.Range("P2:P" & hojaB.Cells(hojaB.Rows.Count, "P").End(xlUp).Row)
        nombre = Trim(celdaB.Value)
        If nombre <> "" Then ' 跳过空单元格
            ' 在源文件中查找对应名称（精确匹配）
            Set celdaA = hojaA.Range("B:B").Find(nombre, LookIn:=xlValues, LookAt:=xlWhole)
            
            If Not celdaA Is Nothing Then
                ' 从名称行下方开始查找当前组的Subtotal
                filaSubtotalA = hojaA.Range(celdaA.Row + 1, hojaA.Cells(hojaA.Rows.Count, celdaA.Column)).Find("Subtotal", LookIn:=xlValues, LookAt:=xlWhole).Row
                
                ' 确定要复制的数据范围：DATA1到DATA3列，从名称下一行到Subtotal上一行
                Set rangoDatos = hojaA.Range(celdaA.Offset(1, 1), hojaA.Cells(filaSubtotalA - 1, celdaA.Column + 2))
                
                ' 清空目标位置的旧数据：从名称下一行到下一个名称前一行
                ultimaFilaDestino = hojaB.Cells(celdaB.Row + 1, "P").End(xlDown).Row
                If ultimaFilaDestino > hojaB.Rows.Count Then ultimaFilaDestino = celdaB.Row + 1
                hojaB.Range(celdaB.Offset(1, 1), hojaB.Cells(ultimaFilaDestino - 1, celdaB.Column + 2)).ClearContents
                
                ' 粘贴数据到目标位置
                rangoDatos.Copy
                celdaB.Offset(1, 1).PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False ' 清除复制状态
            End If
        End If
    Next celdaB

    archivoB.Save
    archivoA.Close SaveChanges:=False ' 源文件无需保存
    archivoB.Close SaveChanges:=True

    MsgBox "Proceso completado", vbInformation

End Sub

关键修改说明

1. 避免重写循环变量：不再修改celdaB，直接使用当前循环的celdaB作为目标位置的起点，保证遍历逻辑正常。
2. 优化Subtotal查找：在名称列内从当前名称行下一行开始查找Subtotal，确保找到的是当前组的结束标记，避免跨组干扰。
3. 清空旧数据：先清除目标位置的原有数据，避免新旧数据重叠导致错位。
4. 添加空值判断：跳过目标列中的空单元格，避免无效查找操作。
5. 清理复制状态：使用Application.CutCopyMode = False释放剪贴板，避免后续操作受剪贴板内容干扰。

内容的提问来源于stack exchange，提问作者Jose L Gutierrez A