[VBA]去重汇总-2

代码来源Excelhome，链接：http://club.excelhome.net/thread-1360829-1-1.html

存着，以后借鉴着用^-^

Sub 去重汇总()

Dim arr, brr
Dim d
Dim i As Integer, j As Integer, n As Integer, m As Integer
Dim lastrow As Integer
Dim str As String
lastrow = Worksheets(1).Range("b65536").End(xlUp).Row
arr = Worksheets(1).Range("b2:f" & lastrow)
Set d = CreateObject("scripting.dictionary")
ReDim brr(1 To lastrow, 1 To 4)
For i = 1 To UBound(arr)
For j = 1 To 2
For k = j + 1 To 3
If arr(i, j) < arr(i, k) Then
tem = arr(i, j)
arr(i, j) = arr(i, k)
arr(i, k) = tem
End If
Next
Next
str = arr(i, 1) & " " & arr(i, 2) & " " & arr(i, 3)
str = Trim(str)
If d.exists(str) = False Then
n = n + 1
d(str) = n
brr(n, 1) = str
m = n
Else
m = d(str)
End If
brr(m, 2) = brr(m, 2) + 1
brr(m, 3) = brr(m, 3) + arr(i, 4)
brr(m, 4) = brr(m, 4) + arr(i, 5)
Next i
Range("i2").Resize(m, 4) = brr

End Sub

效果：