[已解决]递归算法问题求助，万分感谢！

公爵 · 发表于 2016-3-21 12:02

公司发展新媒体渠道拓展业务（新浪微博粉丝通），粉丝客户介绍朋友成为公司粉丝能享受一定优惠。

现需要知道每个粉丝直接、间接给公司带来了多少粉丝。

如A首先是公司的粉丝，然后A介绍了B、C成为了粉丝，然后B、C又分别介绍了其他人成为粉丝……

这样一层一层推荐购买，A发展的粉丝数目=B+C+B发展的粉丝+C发展的粉丝+……，B/C下面所有的粉丝都要算到A头上。

同理，B下面所有的粉丝也要算到B头上。

类似于一个树状结构，现需要根据其中下节点，知道这个节点下面所有的节点数目，如截图。数据源在表格前两列。

想到了可能要用到递归，但是本人文科出身，计算机没有任何基础，写出的VBA代码得不到正确的结果，求高手指点，万分感谢！

最佳答案

月排行榜 / 总排行榜

爱疯

2016-3-21 18:12

Dim d As Object

Sub test()
Dim A, i
Set d = CreateObject("scripting.dictionary")
A = Sheets(1).Range("A1").CurrentRegion

'1）录入字典
For i = 2 To UBound(A)
      d(A(i, 1)) = A(i, 2)
Next i

'2）求A(i,2)被递归的次数
For i = 2 To UBound(A)
      A(i, 2) = IIf(d.exists(A(i, 2)), f(A(i, 2), 1), 1)
Next i
'[AG1].Resize(i - 1, 2) = A '可选，只为看效果

'3）汇总
d.RemoveAll
For i = 2 To UBound(A)
      d(A(i, 1)) = d(A(i, 1)) + 1
Next i
[AI2].Resize(d.Count) = Application.Transpose(d.keys)
[AJ2].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Function f(x, s)
If d(x) <> x Then
      f = f(d(x), s + 1)
Else
      f = s
End If
End Function

树形3.rar (32.67 KB, 下载次数: 16)

爱疯 · 发表于 2016-3-21 18:12

Dim d As Object

Sub test()
Dim A, i
Set d = CreateObject("scripting.dictionary")
A = Sheets(1).Range("A1").CurrentRegion

'1）录入字典
For i = 2 To UBound(A)
      d(A(i, 1)) = A(i, 2)
Next i

'2）求A(i,2)被递归的次数
For i = 2 To UBound(A)
      A(i, 2) = IIf(d.exists(A(i, 2)), f(A(i, 2), 1), 1)
Next i
'[AG1].Resize(i - 1, 2) = A '可选，只为看效果

'3）汇总
d.RemoveAll
For i = 2 To UBound(A)
      d(A(i, 1)) = d(A(i, 1)) + 1
Next i
[AI2].Resize(d.Count) = Application.Transpose(d.keys)
[AJ2].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Function f(x, s)
If d(x) <> x Then
      f = f(d(x), s + 1)
Else
      f = s
End If
End Function

树形3.rar (32.67 KB, 下载次数: 16)

		自动登录	找回密码
密码			注册

[已解决]递归算法问题求助，万分感谢！

评分