'当前人并未作统计,供参考,,,
Option Explicit
Sub test()
Dim arr, i, dic(1), key, t, sum, cnt, m
For i = 0 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
arr = Range("a4:e" & Cells(Rows.Count, "a").End(xlUp).Row).Value
For i = 1 To UBound(arr, 1)
dic(0)(arr(i, 3)) = dic(0)(arr(i, 3)) & Space(1) & arr(i, 1)
dic(1)(arr(i, 1)) = arr(i, 5)
Next
ReDim arr(1 To UBound(arr, 1) * 10, 1 To 3)
For Each key In dic(0).keys
t = Split(dic(0)(key)): sum = 0: cnt = 0
For i = 1 To UBound(t)
sum = sum + dic(1)(t(i)): cnt = cnt + 1
If dic(0).exists(t(i)) Then Call dfs(dic, t(i), sum, cnt)
Next
m = m + 1
arr(m, 1) = key: arr(m, 2) = sum: arr(m, 3) = cnt
Next
[g4].Resize(m, 3) = arr
End Sub
Function dfs(dic, s, sum, cnt)
Dim i, t
If dic(0).exists(s) Then
t = Split(dic(0)(s))
For i = 1 To UBound(t)
sum = sum + dic(1)(t(i)): cnt = cnt + 1
Call dfs(dic, t(i), sum, cnt)
Next
Else
Exit Function
End If
End Function |