html相同值合并显示出来,合并相同数据单元格并显示出汇总数据

Sub Adele()

Dim d As Object, brr(), crr(), drr(), frr()

Set d = CreateObject("scripting.dictionary")

Dim x&, y&, z&, k&, n&

n = 1

With Sheets("数据")

arr = .Range("a1").CurrentRegion

ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))

ReDim frr(1 To UBound(arr), 1 To UBound(arr, 2))

For x = 2 To UBound(arr)

s = arr(x, 1) & "," & arr(x, 2) & "," & arr(x, 3)

If Not d.exists(s) Then

d(s) = arr(x, 4)

Else

d(s) = d(s) & "," & arr(x, 4)

End If

Next

End With

a = d.keys: b = d.items

For i = 0 To UBound(a)

bb = Split(b(i), ",")

ReDim crr(1 To UBound(bb) + 1)

ReDim drr(1 To UBound(bb) + 1)

For j = 0 To UBound(bb)

k = k + 1

crr(k) = bb(j) * 1

Next j

ma = Application.Max(crr)

mi = Application.Min(crr)

su = ma + mi

For y = 1 To UBound(crr)

If crr(y) <> ma And crr(y) <> mi Then

n = n + 1

drr(1) = su

drr(n) = crr(y)

End If

Next y

k = 0

For z = 1 To UBound(drr)

If drr(z) <> "" Then

kk = kk + 1

aa = Split(a(i), ",")

frr(kk, 1) = aa(0)

frr(kk, 2) = aa(1)

frr(kk, 3) = aa(2)

frr(kk, 4) = drr(z)

End If

Next

Next i

With Sheets("结果")

.Range("f2").Resize(UBound(frr), UBound(frr, 2)) = frr

End With

End Sub