Excel VBA匹配指定列行数据并将匹配/不匹配行粘贴至新工作表求助

你可以直接替换原有代码，或者在原有代码基础上追加匹配处理逻辑，以下是整合后的完整代码：

Sub 合并并匹配数据()
    Dim mySheet, arr
    Dim targetSheet As String
    Dim dict As Object
    Dim lastRow As Long, i As Long, j As Long
    Dim matchKey As String
    Dim diffVal As Long
    Dim wsMatch As Worksheet, wsNoMatch As Worksheet
    Dim wsData As Worksheet
    
    ' 第一步：合并Sheet1、Sheet2数据到Sheet3
    arr = Array("Sheet1", "Sheet2")
    targetSheet = "Sheet3"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False ' 关闭删除工作表时的弹窗提示
    
    ' 清空原有Sheet3内容
    On Error Resume Next
    Sheets(targetSheet).Cells.Clear
    On Error GoTo 0
    
    For Each mySheet In arr
        Sheets(mySheet).Range("A1").CurrentRegion.Copy
        With Sheets(targetSheet)
            .Range("A1").Insert Shift:=xlDown
            If mySheet <> arr(UBound(arr)) Then .Rows(1).Delete xlUp
        End With
    Next mySheet
    
    ' 第二步：创建匹配结果工作表
    ' 删除已存在的旧结果表
    On Error Resume Next
    Sheets("匹配成功").Delete
    Sheets("匹配失败").Delete
    On Error GoTo 0
    Set wsMatch = Sheets.Add(after:=Sheets(Sheets.Count))
    wsMatch.Name = "匹配成功"
    Set wsNoMatch = Sheets.Add(after:=Sheets(Sheets.Count))
    wsNoMatch.Name = "匹配失败"
    
    ' 复制表头到两个结果表
    Set wsData = Sheets(targetSheet)
    lastRow = wsData.Cells(Rows.Count, "A").End(xlUp).Row
    wsData.Rows(1).Copy wsMatch.Rows(1)
    wsData.Rows(1).Copy wsNoMatch.Rows(1)
    
    ' 初始化字典存储已遍历行的匹配信息
    Set dict = CreateObject("Scripting.Dictionary")
    ' 匹配键规则：C列&"|"&D列&"|"&E列&"|"&I列
    For i = 2 To lastRow ' 跳过表头，无表头可改为i=1
        matchKey = wsData.Cells(i, "C").Value & "|" & wsData.Cells(i, "D").Value & "|" & wsData.Cells(i, "E").Value & "|" & wsData.Cells(i, "I").Value
        If dict.exists(matchKey) Then
            ' 找到匹配行，计算差值
            j = dict(matchKey)
            diffVal = wsData.Cells(i, "H").Value - wsData.Cells(j, "H").Value
            ' 复制当前行到匹配成功表
            wsData.Rows(i).Copy wsMatch.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ' 替换H列为差值，不需要绝对值可以删掉Abs()
            wsMatch.Cells(Rows.Count, "A").End(xlUp).Offset(0, 7).Value = Abs(diffVal)
            ' 移除字典中已处理的键
            dict.Remove matchKey
        Else
            ' 未找到匹配，存入字典
            dict.Add matchKey, i
        End If
    Next i
    
    ' 字典中剩余的都是未匹配的行，处理到匹配失败表
    For Each Key In dict.keys
        j = dict(Key)
        wsData.Rows(j).Copy wsNoMatch.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        ' 无匹配对时H列默认填0，可按需修改为其他值
        wsNoMatch.Cells(Rows.Count, "A").End(xlUp).Offset(0, 7).Value = 0
    Next Key
    
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set dict = Nothing
    Set wsMatch = Nothing
    Set wsNoMatch = Nothing
    Set wsData = Nothing
    
    MsgBox "数据处理完成，结果已保存到【匹配成功】和【匹配失败】工作表", vbInformation
End Sub

• 如需调整匹配维度，直接修改matchKey的拼接规则即可
• 若不需要自动合并Sheet1和Sheet2，可以删除第一步的合并代码，直接处理已有的Sheet3数据

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