Option Explicit
''ModuleName="模块1"
Dim aData, dic As Object, aRes
Sub start()
Dim i&, n&, aTmp, minNum, maxNum
Dim spNum&, strData, id, num
aData = Range("a1").CurrentRegion
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(aData)
strData = strData_let(i)
aTmp = Split(aData(i, 1), ".")
id = aTmp(0)
spNum = aTmp(1)
num = aData(i, 2)
If Not dic.exists(id) Then
Set dic(id) = CreateObject("Scripting.Dictionary")
End If
If Not dic(id).exists(strData) Then
Set dic(id)(strData) = CreateObject("Scripting.Dictionary")
End If
dic(id)(strData)(spNum) = num
Next
ReDim aRes(1 To UBound(aData), 1 To 6)
For Each id In dic.keys
For Each strData In dic(id).keys
num = 0
For Each aTmp In dic(id)(strData).items
num = num + aTmp
Next
n = n + 1
If dic(id)(strData).Count > 1 Then
minNum = Format(Application.Min(dic(id)(strData).keys), "000")
maxNum = Format(Application.Max(dic(id)(strData).keys), "000")
aRes(n, 1) = id & "." & minNum & "-" & maxNum
Else
aRes(n, 1) = id & "." & Format(dic(id)(strData).keys()(0), "000")
End If
aRes(n, 2) = num
strData_get strData, n
Next
Next
Range("H2").Resize(n, 6) = aRes
End Sub
Function strData_let(r&)
Dim c&
For c = 3 To UBound(aData, 2)
strData_let = strData_let & "|" & aData(r, c)
Next
End Function
Sub strData_get(s, r&)
Dim arr, i&
arr = Split(s, "|")
For i = 1 To UBound(arr)
aRes(r, 2 + i) = arr(i)
Next
End Sub