VBA修改二维数组去重代码实现两数组重复项提取至独立数组

问题根因 #

• 原代码实现的是两个数组的差集（提取arr1中arr2不存在的项）：第一个循环将arr1的所有行拼接为唯一key存入Collection（利用Collection不可存储重复key的特性自动给arr1去重）；第二个循环遍历arr2时，只要发现和arr1重复的项，Add操作就会触发key重复错误，原代码此时执行Remove操作将该key从Collection中删除，最终Collection保留的是仅在arr1出现的内容，和提取重复项的需求完全相反。
• 直接替换判断运算符<>为=无法运行的原因：Err.Number = 0代表Add操作执行成功，即当前项在arr1中不存在、不属于重复项，此时执行Remove操作会触发“对象不存在”的错误，因为Collection中根本没有存储这个key。

具体修改逻辑 #

不需要调整单个判断符号，直接重构第二个遍历arr2的循环逻辑，新增独立Collection存储重复项即可，核心逻辑如下：

• 保留第一个循环，将arr1所有行的拼接key存入原始Collection
• 遍历arr2时，不执行Add操作，直接尝试读取原始Collection中对应key的内容：如果读取不报错，说明该key在arr1中存在，即为两个数组的重复项
• 将识别到的重复项存入独立的重复项Collection，自动完成结果去重，避免arr2自身的重复行导致输出冗余
• 循环结束后关闭错误捕获，避免后续代码错误被静默忽略

修改后完整代码 #

Sub test()

Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim coll As Collection
Dim dupColl As Collection
Dim I As Long, ii As Long, txt As String, x, temp
Dim lastRowColumnA As Long


With Worksheets("Sheet1")
    lastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr1 = .Range("A2:C" & lastRowColumnA).Value
End With

With Worksheets("Sheet2")
    lastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr2 = .Range("A2:C" & lastRowColumnA).Value
End With

Set coll = New Collection
Set dupColl = New Collection
On Error Resume Next
' 加载arr1所有行key到集合
For I = LBound(arr1, 1) To UBound(arr1, 1)
    txt = Join(Array(arr1(I, 1), arr1(I, 2), arr1(I, 3)), Chr(2))
    coll.Add txt, txt
Next I

' 遍历arr2匹配重复项
For I = LBound(arr2, 1) To UBound(arr2, 1)
    txt = Join(Array(arr2(I, 1), arr2(I, 2), arr2(I, 3)), Chr(2))
    Err.Clear
    temp = coll(txt)
    ' 无报错说明key存在，即为重复项
    If Err.Number = 0 Then
        dupColl.Add txt, txt
    End If
Next I
On Error GoTo 0

' 转换重复项集合为输出数组
ReDim arr3(1 To dupColl.Count, 1 To 3)
For I = 1 To dupColl.Count
    x = Split(dupColl(I), Chr(2))
    For ii = 0 To 2
        arr3(I, ii + 1) = x(ii)
    Next
Next I

' 输出结果
Worksheets("test").Range("A2").Resize(UBound(arr3, 1), 3).Value = arr3
Columns("A:C").EntireColumn.AutoFit
End Sub

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