VBA跨工作表匹配行后批量复制多段指定列数据的实现问题

看起来你已经顺利搞定第一部分的列复制逻辑了，现在要拓展到第二组列的复制需求对吧？其实核心思路还是基于找到的匹配行的行号，精准定位两个不同的目标区域就能解决问题，我帮你调整并完善代码：

修改后的完整代码 #

Private Sub CmdBtnUpdate_Click()
    'This is the section to pull the updated FUZE information from the dump.
    Dim FUZEProjectIDFUZEDUMP As String
    Dim MyRange As Range
    Dim j As Integer
    Dim lRow As Long, matchRow As Long ' 统一声明为Long类型，避免类型混淆
    
    ' 关闭屏幕更新，提升批量处理的运行速度
    Application.ScreenUpdating = False
    
    lRow = Sheets("FUZE Dump").Range("A50000").End(xlUp).Row
    
    For j = lRow To 1 Step -1
        FUZEProjectIDFUZEDUMP = Sheets("FUZE Dump").Range("A" & j)
        
        ' 查找匹配项，指定LookAt:=xlWhole确保完全匹配，避免部分匹配的错误
        Set MyRange = Sheets("Main").Range("B:B").Find(What:=FUZEProjectIDFUZEDUMP, LookAt:=xlWhole)
        
        If Not MyRange Is Nothing Then
            matchRow = MyRange.Row ' 获取Main表中匹配行的行号
            
            ' 第一组复制：FUZE Dump的A:H → Main的B:I
            Sheets("FUZE Dump").Range("A" & j & ":H" & j).Copy _
                Destination:=Sheets("Main").Range("B" & matchRow & ":I" & matchRow)
            
            ' 第二组复制：FUZE Dump的J:Y → Main的AM:BA
            Sheets("FUZE Dump").Range("J" & j & ":Y" & j).Copy _
                Destination:=Sheets("Main").Range("AM" & matchRow & ":BA" & matchRow)
        Else
            ' 优化提示信息，方便定位未找到的项目
            MsgBox "在Main表中未找到行" & j & "的项目ID：" & FUZEProjectIDFUZEDUMP
        End If
    Next j
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "数据更新完成！"
End Sub

关键调整说明 #

1. 明确匹配行的行号：通过matchRow = MyRange.Row获取Main表中匹配行的行号，这样就能精准定位两组目标列的起始位置，彻底避免复制区域错位的问题。
2. 拆分两组复制逻辑：分别指定两个独立的复制源区域和目标区域，完全对应你需要的列映射关系（A:H→B:I、J:Y→AM:BA）。
3. 优化查找与运行效率：
   • 给Find方法加上LookAt:=xlWhole参数，确保是完全匹配项目ID，避免出现部分匹配导致的错误复制。
   • 添加Application.ScreenUpdating = False关闭屏幕刷新，大幅提升批量处理的运行速度，最后再恢复屏幕更新。
4. 优化提示信息：在未找到匹配项时，提示具体的行号和项目ID，方便你快速排查问题。

这样修改后，就能同时完成两组列的精准复制，不会再打乱Main表的结构啦~

备注：内容来源于stack exchange，提问作者Michael Pierotti