VBA实现Excel跨工作簿复制整表粘贴到指定位置问题求助

原有代码的问题点 #

• 文件名识别错误：Windows(" PERIMETRE.xlsx") 中的文件名前多了一个多余空格，会导致系统无法匹配到对应工作簿窗口
• 复制范围冗余：直接选中整列A:F会复制近百万行空数据，不仅运行效率极低，从D2位置开始粘贴时还会因为行数量不匹配触发报错
• 操作逻辑不稳定：过度依赖Activate、Select类操作，工作簿/工作表被人为切换时就会运行失败，大数量场景下执行效率极低

可直接使用的优化代码 #

Sub 跨表复制数据()
    ' 声明对象变量
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long
    
    ' 绑定对应工作簿，注意文件名不要拼写错误、不要加多余空格
    Set wbSource = Workbooks("PERIMETRE.xlsx")
    Set wbTarget = Workbooks("OP_COMMERCIALES.xlsm")
    ' 绑定对应工作表
    Set wsSource = wbSource.Worksheets(1) ' 源数据如果不在第一个工作表，可修改为对应表名，比如Worksheets("导出表")
    Set wsTarget = wbTarget.Worksheets("DETAIL")
    
    ' 读取源数据A列最后一行有内容的行号，仅复制有效数据
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 直接赋值复制，比Copy/Paste效率高数十倍，无需切换窗口
    wsTarget.Range("D2").Resize(lastRow, 6).Value = wsSource.Range("A1:F" & lastRow).Value
End Sub

补充说明 #

• 运行代码前请确认两个工作簿都已经处于打开状态
• 如果需要保留原表格的单元格格式，可以把最后一句赋值代码替换为以下内容：

  ' 需保留格式时使用这段代码替换上面的直接赋值代码
  wsSource.Range("A1:F" & lastRow).Copy Destination:=wsTarget.Range("D2")
  

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