VBA合并For Each循环实现按ID匹配同步导入多段指定列数据

修正后完整代码 #

Sub Button1_Click()
    
    Dim OpenFileName As String
    Dim wb As Workbook
    Dim wsCopy As Worksheet
    Dim wsDest As Worksheet
    Dim m As Variant, i As Long, lastRow As Long
    
    OpenFileName = Application.GetOpenFilename '选择并打开源工作簿
    If OpenFileName = "False" Then Exit Sub
    
    Set wb = Workbooks.Open(OpenFileName, ReadOnly:=True)
    Set wsCopy = wb.Worksheets(1) '按需调整为指定工作表
    Set wsDest = Workbooks("Learner data Elliot.xlsx").Worksheets(1)
    
    ' 读取源表数据最后一行行号
    lastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row
    
    ' 单次遍历所有数据行
    For i = 2 To lastRow
        ' 仅执行一次ID匹配，ID存储在源表B列
        m = Application.Match(wsCopy.Cells(i, "B").Value, wsDest.Columns("A"), 0)
        ' 无匹配时取目标表空白新行行号
        If IsError(m) Then m = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
        
        ' 复制B-F列数据到目标表A列起始位置
        wsCopy.Range("B" & i & ":F" & i).Copy wsDest.Cells(m, "A")
        ' 复制S-T列数据到目标表I列起始位置
        wsCopy.Range("S" & i & ":T" & i).Copy wsDest.Cells(m, "I")
    Next i
    
    wb.Close SaveChanges:=False
    MsgBox "Done"
        
End Sub

修改说明 #

• 两次循环合并为单次行遍历，ID仅匹配一次，运行效率更高，避免了两次循环匹配错位的问题
• 直接按行号遍历，分别指定需要复制的列范围，无需额外做偏移计算，逻辑清晰不易出错

原Offset方案问题说明 #

你给S2:T范围加Offset(0,-17)后，实际选中的区域已经变成了B2:C列，所以rw.Copy时复制的自然是B、C两列的数据。如果要沿用Offset写法，只需将偏移作用于ID取值环节即可：

For Each rw In wsCopy.Range("S2:T" & wsCopy.Cells(Rows.Count, "B").End(xlUp).Row).Rows
    ' 仅对ID取值做偏移，不修改选中的复制区域
    m = Application.Match(rw.Offset(0, -17).Cells(1).Value, wsDest.Columns("A"), 0)
    If IsError(m) Then m = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
    ' 直接复制当前选中的S:T列
    rw.Copy wsDest.Cells(m, "I")
Next rw

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