如何修改Excel VBA脚本实现两工作表差异比对并复制整行到指定页

修改后可直接运行的VBA代码 #

以下代码完全匹配你现有公式的三列匹配逻辑，支持输出完整16列数据+差异标识列：

Sub GetExcelSheetDiff()
    Dim dictOld As Object, dictNew As Object
    Dim i As Long, lastRow As Long, outputRow As Long
    Dim wsOld As Worksheet, wsNew As Worksheet, wsOutput As Worksheet
    Dim key As String
    
    ' 初始化字典存匹配键
    Set dictOld = CreateObject("Scripting.Dictionary")
    Set dictNew = CreateObject("Scripting.Dictionary")
    ' 绑定工作表
    Set wsOld = ThisWorkbook.Worksheets("Old")
    Set wsNew = ThisWorkbook.Worksheets("New")
    ' 创建/清空差异输出表
    On Error Resume Next
    Set wsOutput = ThisWorkbook.Worksheets("DiffResult")
    If Err.Number <> 0 Then
        Set wsOutput = ThisWorkbook.Worksheets.Add(after:=wsNew)
        wsOutput.Name = "DiffResult"
    End If
    On Error GoTo 0
    wsOutput.Cells.Clear
    outputRow = 1
    ' 写入表头：复制原表前16列表头，第17列加标识
    wsOld.Range(wsOld.Cells(1, "A"), wsOld.Cells(1, "P")).Copy wsOutput.Cells(1, "A")
    wsOutput.Cells(1, "Q") = "差异类型"
    outputRow = outputRow + 1
    
    ' 存储Old表所有匹配键
    lastRow = wsOld.Cells(wsOld.Rows.Count, "H").End(xlUp).Row
    For i = 2 To lastRow ' 若表头行数不同，自行修改起始行号
        key = Join(Array(wsOld.Cells(i, "B"), wsOld.Cells(i, "C"), wsOld.Cells(i, "H")), "|")
        If Not dictOld.Exists(key) Then dictOld.Add key, i
    Next i
    
    ' 存储New表所有匹配键
    lastRow = wsNew.Cells(wsNew.Rows.Count, "H").End(xlUp).Row
    For i = 2 To lastRow
        key = Join(Array(wsNew.Cells(i, "B"), wsNew.Cells(i, "C"), wsNew.Cells(i, "H")), "|")
        If Not dictNew.Exists(key) Then dictNew.Add key, i
    Next i
    
    ' 找removed数据：Old有New没有
    For Each key In dictOld.Keys
        If Not dictNew.Exists(key) Then
            wsOld.Range(wsOld.Cells(dictOld(key), "A"), wsOld.Cells(dictOld(key), "P")).Copy wsOutput.Cells(outputRow, "A")
            wsOutput.Cells(outputRow, "Q") = "removed（删除）"
            outputRow = outputRow + 1
        End If
    Next key
    
    ' 找added数据：New有Old没有
    For Each key In dictNew.Keys
        If Not dictOld.Exists(key) Then
            wsNew.Range(wsNew.Cells(dictNew(key), "A"), wsNew.Cells(dictNew(key), "P")).Copy wsOutput.Cells(outputRow, "A")
            wsOutput.Cells(outputRow, "Q") = "added（新增）"
            outputRow = outputRow + 1
        End If
    Next key
    
    ' 自动调整列宽
    wsOutput.UsedRange.EntireColumn.AutoFit
    MsgBox "差异提取完成，共找到" & outputRow - 2 & "条差异数据", vbInformation
End Sub

使用注意事项 #

• 代码默认数据第1行为表头，实际数据从第2行开始，如果你的表结构不同，自行修改For i = 2 To lastRow里的起始行号即可
• 匹配键默认和你现有公式逻辑一致，取B、C、H三列拼接判断，如果需要调整匹配字段，修改key = Join(Array(wsOld.Cells(i, "B"), wsOld.Cells(i, "C"), wsOld.Cells(i, "H")), "|")里的列标识即可
• 代码默认完整数据为A到P共16列，如果实际列范围不同，修改对应复制行里的列范围即可

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