需求：基于ID与列头匹配将Sheet1整行复制至Sheet2（需VBA代码）

我完全懂你的困扰——用VLOOKUP处理这种跨表匹配时，不仅会出现烦人的#N/A错误，还可能不小心覆盖Sheet2里的原有数据。下面这段VBA代码可以完美解决你的需求：基于唯一ID匹配，将Sheet1的整行数据按列头对应复制到Sheet2，且不会覆盖ID不匹配的原有内容。

Sub CopyMatchingRowsByID()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim sourceLastRow As Long, targetLastRow As Long
    Dim sourceHeaderRow As Long, targetHeaderRow As Long
    Dim sourceIDCol As Long, targetIDCol As Long
    Dim idRange As Range, cell As Range
    Dim headerDict As Object
    Dim i As Long, j As Long
    
    ' 设置工作表（可根据实际情况修改名称）
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    
    ' 设置表头行（假设表头在第1行，若不是可修改）
    sourceHeaderRow = 1
    targetHeaderRow = 1
    
    ' 创建字典存储Sheet2的列头与列号对应关系
    Set headerDict = CreateObject("Scripting.Dictionary")
    For j = 1 To wsTarget.Cells(targetHeaderRow, Columns.Count).End(xlToLeft).Column
        headerDict(UCase(wsTarget.Cells(targetHeaderRow, j).Value)) = j
    Next j
    
    ' 找到Sheet1和Sheet2的ID列（假设ID列名为"ID"，可修改）
    sourceIDCol = wsSource.Rows(sourceHeaderRow).Find(What:="ID", LookIn:=xlValues, LookAt:=xlWhole).Column
    targetIDCol = wsTarget.Rows(targetHeaderRow).Find(What:="ID", LookIn:=xlValues, LookAt:=xlWhole).Column
    
    ' 获取Sheet1的最后一行数据
    sourceLastRow = wsSource.Cells(Rows.Count, sourceIDCol).End(xlUp).Row
    ' 获取Sheet2的最后一行数据
    targetLastRow = wsTarget.Cells(Rows.Count, targetIDCol).End(xlUp).Row
    
    ' 遍历Sheet2的所有ID，匹配Sheet1的数据
    Set idRange = wsTarget.Range(wsTarget.Cells(targetHeaderRow + 1, targetIDCol), wsTarget.Cells(targetLastRow, targetIDCol))
    
    For Each cell In idRange
        ' 在Sheet1中查找匹配的ID
        On Error Resume Next
        Dim matchRow As Long
        matchRow = wsSource.Columns(sourceIDCol).Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole).Row
        On Error GoTo 0
        
        ' 如果找到匹配的ID，按列头复制数据
        If matchRow > 0 Then
            For j = 1 To wsSource.Cells(sourceHeaderRow, Columns.Count).End(xlToLeft).Column
                Dim headerName As String
                headerName = UCase(wsSource.Cells(sourceHeaderRow, j).Value)
                ' 如果Sheet2有对应的列头，复制数据
                If headerDict.Exists(headerName) Then
                    wsTarget.Cells(cell.Row, headerDict(headerName)).Value = wsSource.Cells(matchRow, j).Value
                End If
            Next j
        End If
    Next cell
    
    MsgBox "数据匹配复制完成！", vbInformation
End Sub

• 列头自动匹配：用字典存储Sheet2的列头和列号映射关系，不管列头位置如何变化，只要名称一致就能精准对应复制
• 保护原有数据：仅处理Sheet2中能在Sheet1找到匹配ID的行，不匹配的行原有内容完全保留，不会出现#N/A或被覆盖
• 灵活配置：可根据你的实际表格修改工作表名称、表头行号、ID列名称
• 错误兼容：加入错误捕获逻辑，避免因ID不存在导致代码中断

1. 打开目标Excel文件，按下Alt + F11打开VBA编辑器
2. 插入新模块：右键点击左侧工作簿名称 → 插入 → 模块
3. 将上面的代码粘贴到模块中
4. 修改代码中的工作表名称、表头行号、ID列名称（如果和你的表格不一致）
5. 按下F5运行代码，或回到Excel界面，通过「开发工具」→「宏」→ 选择CopyMatchingRowsByID执行

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