Excel双表对比：排查识别Sheet2相对Sheet1缺失新增数据的VBA宏假阳性问题

原有代码问题原因 #

• 硬编码VLOOKUP查找范围为固定行数R2C1:R7443C1，如果基线表、新表的实际数据行数和该数值不匹配，就会出现匹配遗漏，触发假阳性
• 未对VLOOKUP返回的错误值（#N/A）做判断筛选，无法准确区分匹配成功和匹配失败的条目
• 大量使用Select、Selection这类依赖工作表激活状态的操作，容易出现粘贴错位、取值错误的问题
• 依赖额外的辅助表存储复制内容，增加了出错概率

修复后代码 #

Sub MacroCompare()
    Dim baselineSht As Worksheet, testSht As Worksheet, compSht As Worksheet
    Dim baselineDict As Object, testDict As Object
    Dim i As Long, lastRow As Long, missingRow As Long, extraRow As Long
    Dim tempVal As String
    
    ' 绑定工作表，可根据你的实际表名修改
    Set baselineSht = ThisWorkbook.Sheets("Sheet1") ' 基线表
    Set testSht = ThisWorkbook.Sheets("Sheet2") ' 新数据表
    Set compSht = ThisWorkbook.Sheets("Sheet3") ' 对比结果表
    Set baselineDict = CreateObject("Scripting.Dictionary")
    Set testDict = CreateObject("Scripting.Dictionary")
    
    ' 清空对比表原有内容
    compSht.Cells.Clear
    
    ' 写入表头
    compSht.Range("A1") = "基线表拼接值"
    compSht.Range("B1") = "新数据表拼接值"
    compSht.Range("C1") = "缺失数据（新表不存在）"
    compSht.Range("D1") = "新增数据（基线不存在）"
    
    ' 读取基线表H列所有非空值存入字典，同时写入对比表A列
    lastRow = baselineSht.Cells(baselineSht.Rows.Count, "H").End(xlUp).Row
    For i = 2 To lastRow ' 跳过表头，如果你H列没有表头就从i=1开始
        tempVal = Trim(baselineSht.Cells(i, "H").Value)
        If tempVal <> "" And Not baselineDict.Exists(tempVal) Then
            baselineDict.Add tempVal, ""
            compSht.Cells(i, "A") = tempVal
        End If
    Next i
    
    ' 读取新数据表H列所有非空值存入字典，同时写入对比表B列
    lastRow = testSht.Cells(testSht.Rows.Count, "H").End(xlUp).Row
    For i = 2 To lastRow ' 跳过表头，如果你H列没有表头就从i=1开始
        tempVal = Trim(testSht.Cells(i, "H").Value)
        If tempVal <> "" And Not testDict.Exists(tempVal) Then
            testDict.Add tempVal, ""
            compSht.Cells(i, "B") = tempVal
        End If
    Next i
    
    ' 筛选缺失数据：基线有、新表没有的值
    missingRow = 2
    For Each tempVal In baselineDict.Keys
        If Not testDict.Exists(tempVal) Then
            compSht.Cells(missingRow, "C") = tempVal
            missingRow = missingRow + 1
        End If
    Next tempVal
    
    ' 筛选新增数据：新表有、基线没有的值
    extraRow = 2
    For Each tempVal In testDict.Keys
        If Not baselineDict.Exists(tempVal) Then
            compSht.Cells(extraRow, "D") = tempVal
            extraRow = extraRow + 1
        End If
    Next tempVal
    
    ' 释放对象
    Set baselineDict = Nothing
    Set testDict = Nothing
    Set baselineSht = Nothing
    Set testSht = Nothing
    Set compSht = Nothing
    
    MsgBox "对比完成，结果已写入Sheet3"
End Sub

代码说明 #

• 动态读取两个表的实际有效行数，不需要硬编码范围，适配任意数据量的表格
• 使用字典存储拼接值，对比效率远高于VLOOKUP，万行级数据也可以秒出结果
• 自动去重、跳过空值，避免空白单元格导致的假阳性匹配
• 不需要额外的辅助表，所有操作直接在三个目标表完成，运行稳定不会错位
• 如果你H列没有表头，把两处循环的起始值i = 2改成i = 1即可

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