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