如何用VBA对比两个不同长度、各含3列的表格，提取双方独有条目

实现逻辑 #

• 采用字典存储每行的唯一拼接键，匹配效率远高于逐行循环比对，适合数据量较大的场景
• 三列内容用特殊分隔符拼接为唯一键，严格区分大小写、数值精度、日期格式，任意一列不一致即判定为条目不匹配
• 结果直接输出到原数据区域右侧，自动添加区分表头

操作前准备 #

• 确认两张待比对表的表名，默认代码适配表名为表A、表B，可自行修改
• 确认数据起始行（默认第2行，首行为表头），可按需调整参数

可直接运行的VBA代码 #

Sub 对比两表找独有条目()
    Dim dictA As Object, dictB As Object
    Dim i As Long, lastRowA As Long, lastRowB As Long
    Dim key As String, outputCol As Long
    
    ' 初始化字典，设置为区分大小写匹配
    Set dictA = CreateObject("Scripting.Dictionary")
    dictA.CompareMode = vbBinaryCompare
    Set dictB = CreateObject("Scripting.Dictionary")
    dictB.CompareMode = vbBinaryCompare
    
    ' ==========参数配置区，可按需修改==========
    Const sheetAName = "表A" ' 待比对的第一个表名
    Const sheetBName = "表B" ' 待比对的第二个表名
    Const dataStartRow = 2 ' 数据起始行（首行是表头的话填2）
    Const compareColCount = 3 ' 比对的列数，固定为3无需改
    ' ========================================
    
    ' 读取表A所有行存入字典
    With Sheets(sheetAName)
        lastRowA = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = dataStartRow To lastRowA
            ' 三列用特殊分隔符拼接为唯一键，避免内容串扰
            key = .Cells(i, 1).Value & "|" & .Cells(i, 2).Value & "|" & .Cells(i, 3).Value
            ' 字典存储键和对应的整行内容
            If Not dictA.exists(key) Then
                dictA.Add key, Array(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, 3).Value)
            End If
        Next i
    End With
    
    ' 读取表B所有行存入字典
    With Sheets(sheetBName)
        lastRowB = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = dataStartRow To lastRowB
            key = .Cells(i, 1).Value & "|" & .Cells(i, 2).Value & "|" & .Cells(i, 3).Value
            If Not dictB.exists(key) Then
                dictB.Add key, Array(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, 3).Value)
            End If
        Next i
    End With
    
    ' 确定输出起始列（原数据第3列右侧空一列开始输出）
    outputCol = compareColCount + 2
    
    ' 输出表A独有的条目
    Sheets(sheetAName).Cells(1, outputCol).Value = "表A独有、表B无的条目"
    Sheets(sheetAName).Cells(1, outputCol).Font.Bold = True
    i = dataStartRow
    For Each k In dictA.keys
        If Not dictB.exists(k) Then
            Sheets(sheetAName).Cells(i, outputCol).Resize(1, 3).Value = dictA(k)
            i = i + 1
        End If
    Next k
    
    ' 空一列后输出表B独有的条目
    outputCol = outputCol + 4
    Sheets(sheetAName).Cells(1, outputCol).Value = "表B独有、表A无的条目"
    Sheets(sheetAName).Cells(1, outputCol).Font.Bold = True
    i = dataStartRow
    For Each k In dictB.keys
        If Not dictA.exists(k) Then
            Sheets(sheetAName).Cells(i, outputCol).Resize(1, 3).Value = dictB(k)
            i = i + 1
        End If
    Next k
    
    ' 释放对象
    Set dictA = Nothing
    Set dictB = Nothing
    MsgBox "比对完成，结果已输出到表A右侧"
End Sub

使用说明 #

1. 打开Excel文件，按Alt+F11打开VBA编辑器，插入模块，将上述代码粘贴到模块中
2. 根据自己的实际表名、数据起始行修改代码参数配置区的对应内容
3. 按F5运行代码即可得到结果
4. 如果需要结果输出到其他位置，调整代码中输出列的逻辑即可

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