求可对比两个工作表并拆分匹配值、唯一值分表存储的Excel VBA宏

本代码适配你的需求场景，对比同一工作簿Sheet1A列和Sheet2A列，将仅在单表出现的唯一值写入Sheet3A列，两表都出现的重复值写入Sheet4A列，采用字典实现，支持万行级数据高效处理，默认不区分大小写匹配。

对比规则说明：

• 重复值：同时出现在Sheet1 A列和Sheet2 A列的值
• 唯一值：仅在Sheet1 A列出现，或仅在Sheet2 A列出现的值
  你可以根据下方使用说明调整匹配规则

Sub CompareTwoSheets()
    Dim dict As Object
    Dim arrSheet1 As Variant, arrSheet2 As Variant
    Dim arrUnique As Variant, arrDuplicate As Variant
    Dim i As Long, nUnique As Long, nDuplicate As Long
    
    ' 读取Sheet1和Sheet2 A列已用数据到数组，提升运行效率
    arrSheet1 = Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row).Value
    arrSheet2 = Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    ' 初始化字典，默认不区分大小写，需区分可将CompareMode改为0
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = 1
    
    ' 预定义结果数组最大长度，避免频繁扩容
    ReDim arrUnique(1 To UBound(arrSheet1) + UBound(arrSheet2), 1 To 1)
    ReDim arrDuplicate(1 To UBound(arrSheet1), 1 To 1)
    
    ' 第一步：将Sheet2所有非空值装入字典，标记为未匹配状态
    For i = 1 To UBound(arrSheet2)
        If arrSheet2(i, 1) <> "" And Not dict.exists(arrSheet2(i, 1)) Then
            dict.Add arrSheet2(i, 1), False
        End If
    Next i
    
    ' 第二步：遍历Sheet1值，区分重复和Sheet1独有唯一值
    For i = 1 To UBound(arrSheet1)
        If arrSheet1(i, 1) <> "" Then
            If dict.exists(arrSheet1(i, 1)) Then
                nDuplicate = nDuplicate + 1
                arrDuplicate(nDuplicate, 1) = arrSheet1(i, 1)
                ' 标记该值已在Sheet1匹配，排除出Sheet2独有值范围
                dict(arrSheet1(i, 1)) = True
            Else
                nUnique = nUnique + 1
                arrUnique(nUnique, 1) = arrSheet1(i, 1)
            End If
        End If
    Next i
    
    ' 第三步：将Sheet2独有未匹配值加入唯一值数组
    Dim key As Variant
    For Each key In dict.keys
        If dict(key) = False Then
            nUnique = nUnique + 1
            arrUnique(nUnique, 1) = key
        End If
    Next key
    
    ' 清空目标表旧数据并写入结果
    Sheets("Sheet3").Columns("A").ClearContents
    Sheets("Sheet4").Columns("A").ClearContents
    If nUnique > 0 Then Sheets("Sheet3").Range("A1").Resize(nUnique).Value = arrUnique
    If nDuplicate > 0 Then Sheets("Sheet4").Range("A1").Resize(nDuplicate).Value = arrDuplicate
    
    ' 释放内存
    Set dict = Nothing
    MsgBox "对比完成，共找到" & nUnique & "个唯一值，" & nDuplicate & "个重复值", vbInformation
End Sub

使用说明 #

• 打开目标工作簿，按Alt+F11打开VBA编辑器
• 右键点击左侧工程栏的工作簿名称，选择「插入」-「模块」
• 将上述代码粘贴到模块窗口，按F5运行即可
• 可根据需求调整规则：
  • 需要区分大小写匹配，将dict.CompareMode = 1修改为dict.CompareMode = 0
  • 仅需要把Sheet1独有的值作为唯一值，删除第三步遍历字典写入唯一值的段落即可
  • 需要跳过表头从第二行开始对比，将两个数组读取的起始行从1改为2即可

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