Excel VBA跨表匹配ID并复制指定列需求咨询

核心实现思路 #

• 绑定目标工作表，获取数据范围的最后行号，避免遍历空行
• 双层遍历：外层遍历Sheet1的每个ID，内层遍历Sheet2的ID列查找所有匹配项
• 用变量跟踪粘贴位置，处理同一ID的多个匹配结果，避免覆盖
• 可选优化：将Sheet2数据读入数组，减少工作表交互，提升处理速度

基础版代码（适合小数据量） #

Sub MatchIDsAndCopyData()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long
    Dim currentID As String
    Dim pasteRow As Long
    
    ' 指定工作表，根据实际名称修改
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' 获取两表数据区域的最后行号
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历Sheet1的ID列（假设表头在第1行，从第2行开始）
    For i = 2 To lastRow1
        currentID = ws1.Cells(i, "A").Value
        pasteRow = i ' 初始粘贴位置为当前ID行的目标列
        
        ' 遍历Sheet2的ID列找匹配
        For j = 2 To lastRow2
            If ws2.Cells(j, "A").Value = currentID Then
                ' 将Sheet2指定列（这里是C列）内容复制到Sheet1的B列
                ws1.Cells(pasteRow, "B").Value = ws2.Cells(j, "C").Value
                pasteRow = pasteRow + 1 ' 多个匹配时，下一行继续粘贴
            End If
        Next j
    Next i
    
    ' 释放对象，避免内存占用
    Set ws1 = Nothing
    Set ws2 = Nothing
    
    MsgBox "数据匹配复制完成！"
End Sub

优化版代码（适合大数据量） #

通过数组存储Sheet2数据，减少频繁读写工作表的操作，大幅提升效率：

Sub MatchIDsAndCopyData_ArrayOptimized()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long
    Dim currentID As String
    Dim pasteRow As Long
    Dim arrIDs As Variant, arrData As Variant ' 存储Sheet2的ID和目标数据
    
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' 将Sheet2的ID列和目标数据列一次性读入数组
    arrIDs = ws2.Range("A2:A" & lastRow2).Value
    arrData = ws2.Range("C2:C" & lastRow2).Value
    
    ' 遍历Sheet1的ID
    For i = 2 To lastRow1
        currentID = ws1.Cells(i, "A").Value
        pasteRow = i
        
        ' 遍历数组查找匹配项
        For j = LBound(arrIDs) To UBound(arrIDs)
            If arrIDs(j, 1) = currentID Then
                ws1.Cells(pasteRow, "B").Value = arrData(j, 1)
                pasteRow = pasteRow + 1
            End If
        Next j
    Next i
    
    Set ws1 = Nothing
    Set ws2 = Nothing
    
    MsgBox "数据匹配复制完成！"
End Sub

自定义调整说明 #

• 修改列标识：如果Sheet1的ID在D列，把代码中的"A"改成"D"；Sheet2的目标数据在E列，把"C"改成"E"
• 调整表头行：如果没有表头，把循环起始行从2改成1
• 仅保留首个匹配：在内层循环找到匹配后，添加Exit For即可停止查找当前ID的后续匹配项

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