VBA-字典与数组实现去重

在实际操作中有太多的数据需要去重仅保留一条记录，在这里自己写了两个函数，测试OK，需要可以自己稍微改动就可以使用啦。

1.两个数据源合并，仅取第一次出现的数据，具体代码如下，因为注释比较详细，在这里就不过多的说明，需要注意一点的是，我这里使用的数据，去重列是第二列，所以我将字典转换成数组时，是将数组的第2列等于字典的key值，为保持数据结构一致，方便循环操作。

'合并去重，将数据源1和数据源2合并去重保存在数组里，arr0是用来指定去重列和保留列，使用时仅限在两个数组结构一致的情况下使用。
Function totals(arr1, arr2, arr0)
'定义字典，使用字典去重
Dim a1 As Object
Set a1 = CreateObject("Scripting.Dictionary")
'如果数据源1有重复的数据，仅保留第1项
For i = 1 To UBound(arr1, 1)
If a1.exists(arr1(i, arr0(0))) Then
Else
'将所需保留的字段组合成数组保留在字典的key值中，可按需改写
a1(arr1(i, arr0(0))) = Array(arr1(i, arr0(1)), arr1(i, arr0(2)))
End If
Next i

'将在数据源1出现过的数据删除，仅保留不重复的部分
For i = 1 To UBound(arr2, 1)
If a1.exists(arr2(i, arr0(0))) Then
Else
a1(arr2(i, arr0(0))) = Array(arr2(i, arr0(1)), arr2(i, arr0(2)))
End If
Next i
'将字典转换成数组，可按需改写
Dim sumarr()
i = 1
ReDim sumarr(1 To a1.Count, 1 To 3)
For Each k In a1.keys
sumarr(i, 2) = k
sumarr(i, 1) = a1(k)(0)
sumarr(i, 3) = a1(k)(1)
i = 1 + i
Next k
totals = sumarr
End Function

2.将历史数据去除，这里是将数据源2作为历史数据，逻辑与第一个合并去重的函数类似，在这里就不做过多的说明

'去重保留，仅保留数据源1，且不在数据源2的数据，即去除数据源2的数据
Function afterdelete(arr1, arr2, arr0)

Dim a1 As Object
Set a1 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr1, 1)
If a1.exists(arr1(i, arr0(0))) Then
Else
a1(arr1(i, arr0(0))) = Array(arr1(i, arr0(1)), arr1(i, arr0(2)))
End If
Next i
For i = 1 To UBound(arr2, 1)
If a1.exists(arr2(i, arr0(0))) Then
a1.Remove (arr2(i, arr0(0)))
Else
End If
Next i
'将字典转换成数组,这里的数组保持与原数组结构一致
Dim delete()
i = 1
ReDim delete(1 To a1.Count, 1 To 3)
For Each k In a1.keys
delete(i, 2) = k
delete(i, 1) = a1(k)(0)
delete(i, 3) = a1(k)(1)
i = 1 + i
Next k
afterdelete = delete
End Function

3.这是具体实现的过程
 

Sub test()

'将需要去重合并的数据源转换成数组
Dim book0 As Workbook
Set book0 = ThisWorkbook
Dim w1 As Worksheet
Dim arr11
Set w1 = book0.Worksheets(1)
arr11 = w1.UsedRange
Dim w2 As Worksheet
Dim arr12
Set w2 = book0.Worksheets(2)
arr12 = w2.UsedRange
Dim sumall
'将需要去重的列和需要保留的列号保存在数组里面，方便后续操作，这里的去重列是第2列，保留列是第1，3列
Dim arr0()
arr0 = Array(2, 1, 3)
'这部分若有多个数组，可用循环来实现
sumall = totals(arr11, arr12, arr0)
Dim dill
dill = afterdelete(arr11, arr12, arr0)
'将结果输出到工作表中
Dim w0 As Worksheet
Set w0 = book0.Worksheets.Add
w0.Name = "汇总"
Dim r0 As Range
Set r0 = w0.Cells(1, 1)
r0.Resize(UBound(sumall, 1), UBound(sumall, 2)) = sumall
End Sub