Excel VBA实现新旧模板数据自动更新多区域批量复制问题求助

方案1：交互式手动选择多组映射（适用映射规则不固定的场景） #

支持用户反复选择多组源区域与对应目标起始单元格，直到点击取消终止操作，适配灵活度高的迁移需求。

Sub 多区域批量复制()
    Dim xTitleId As String
    Dim xRng1 As Range, xRng2 As Range
    Dim xAddWb As Workbook ' 源数据工作簿，可按实际逻辑赋值
    Dim xWb As Workbook ' 目标模板工作簿，可按实际逻辑赋值
    
    ' 示例工作簿赋值，替换为实际文件名即可
    ' Set xAddWb = Workbooks("旧模板.xlsx")
    ' Set xWb = Workbooks("新模板.xlsx")
    xTitleId = "多区域数据迁移工具"
    
    On Error Resume Next ' 处理用户点击取消的异常场景
    Do
        ' 选择当前组的源区域
        xAddWb.Activate
        Set xRng1 = Application.InputBox(prompt:="请选择源数据区域（点击取消结束操作）", Title:=xTitleId, Default:="", Type:=8)
        If xRng1 Is Nothing Then Exit Do ' 检测到取消操作，退出循环
        
        ' 选择当前组对应的目标起始单元格
        xWb.Activate
        Set xRng2 = Application.InputBox(prompt:="请选择对应目标区域的起始单元格", Title:=xTitleId, Default:="", Type:=8)
        If xRng2 Is Nothing Then Exit Do
        
        ' 执行单组区域复制
        xRng1.Copy xRng2
        xRng2.CurrentRegion.EntireColumn.AutoFit
        
        ' 清空对象缓存，准备下一组选择
        Set xRng1 = Nothing
        Set xRng2 = Nothing
    Loop
    
    xAddWb.Close SaveChanges:=False
    On Error GoTo 0
End Sub

方案2：预设固定映射关系（适用模板规则固定的存量同步场景） #

提前将新旧模板的对应区域写入代码，无需手动选择，运行后自动完成全部区域迁移，适合批量处理大量同模板文件的场景。

Sub 固定模板多区域批量迁移()
    Dim xTitleId As String
    Dim xSourceRngAddr As Variant, xDestRngAddr As Variant
    Dim i As Integer
    Dim xAddWb As Workbook, xWb As Workbook
    
    ' 配置工作簿参数，替换为实际文件名
    Set xAddWb = Workbooks("旧模板.xlsx")
    Set xWb = Workbooks("新模板.xlsx")
    xTitleId = "固定模板数据迁移工具"
    
    ' 预设映射关系：两个数组顺序一一对应，可按需增删条目
    xSourceRngAddr = Array("A1:C10", "E2:F15", "H1:H20") ' 替换为旧模板各源区域地址
    xDestRngAddr = Array("B1", "D2", "A12") ' 替换为新模板对应目标区域的起始单元格地址
    
    On Error Resume Next
    For i = LBound(xSourceRngAddr) To UBound(xSourceRngAddr)
        ' 执行单组区域复制，如需指定工作表可补充工作表参数，示例：xAddWb.Sheets("Sheet1").Range(...)
        xAddWb.Range(xSourceRngAddr(i)).Copy _
        Destination:=xWb.Range(xDestRngAddr(i))
        
        ' 目标区域列宽自适应
        xWb.Range(xDestRngAddr(i)).CurrentRegion.EntireColumn.AutoFit
    Next i
    On Error GoTo 0
    
    xAddWb.Close SaveChanges:=False
    MsgBox "全部区域迁移完成！", vbInformation, xTitleId
End Sub

核心调整说明 #

• 新增循环处理逻辑，支持任意数量的源-目标区域对独立复制，互不影响
• 保留原有的列宽自适应逻辑，每组区域复制完成后自动适配目标区域列宽
• 新增错误处理，避免用户点击取消或区域参数配置错误时报错中断
• 预设映射模式可大幅降低重复操作成本，适配固定模板的批量迁移需求
• 如需仅粘贴值、格式或公式等特定内容，可将复制逻辑替换为PasteSpecial方法实现，示例（仅粘贴值）：

  xRng1.Copy
  xRng2.PasteSpecial xlPasteValues
  

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