[已解决]如何修改递归代码

雄鹰2013

请帮忙修改附件中的递归代码，正确的如表中所示

最佳答案

月排行榜 / 总排行榜

爱疯

2016-9-12 16:39

'学习改自 7楼 pengyx的方法
http://www.excelpx.com/thread-370343-1-1.html 7楼
Sub test()
    i = [a65536].End(3).Row
    f = Range("a2:a" & i)
    z = Range("b2:b" & i)
    ReDim ar(1 To UBound(z), 1 To 1)

    For i = 1 To UBound(f)
        For j = 1 To UBound(f)
            If f(i, 1) = f(j, 1) Then
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                '求一个儿子及后代的个数
                temp = z(j, 1): k = 0: Child = 1
                Do Until k > UBound(f)   'k > UBound(f)，表示全部比较过
                    For k = 1 To UBound(z)
                        If temp = f(k, 1) Then
                            Child = Child + 1
                            temp = z(k, 1)    '子变父
                            Exit For    '回头
                        End If
                    Next k
                Loop
                ar(i, 1) = ar(i, 1) + Child    '累计到该儿子的父里
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            End If
        Next j
    Next i
    Range("c2").Resize(UBound(z), 1) = ar
End Sub

dg4.rar (7.83 KB, 下载次数: 2)

2016-9-12 16:39 上传

点击文件名下载附件

跳转到最佳答案楼层

雄鹰2013

有没有好的思路

爱疯

dg2.rar (10 KB, 下载次数: 5)

2016-9-9 23:56 上传

点击文件名下载附件


Dim d As Object
Sub test()
    Dim A, i
    Set d = CreateObject("scripting.dictionary")
    A = Range("a1").CurrentRegion
    '向下查询时，key是父，直到递归的结果不是父
    For i = 2 To UBound(A)
        '一父可能多子，可用嵌套字典或字符串累计。
        If Not d.exists(A(i, 1)) Then Set d(A(i, 1)) = CreateObject("scripting.dictionary")
        'key本身是字典，其中的key代表其子
        d(A(i, 1))(A(i, 2)) = ""
    Next i
    For i = 2 To UBound(A)
        A(i, 3) = dg(A(i, 1))    '传入父
    Next i
    Range("a1").Resize(UBound(A), UBound(A, 2)) = A
End Sub
'递归
Function dg(x) As Integer
    Dim k
    If d.exists(x) Then      'x是父吗？
        For Each k In d(x).keys    '是父，传入x的所有子，继续递归。
            dg = dg + dg(k) + 1
        Next
    Else
        dg = 0    '不是父，说明x是最底层，结束递归。
    End If
End Function



我以前也问过
http://www.excelpx.com/thread-370343-1-1.html

雄鹰2013

爱疯 发表于 2016-9-9 23:57
Dim d As Object
Sub test()
    Dim A, i

下标好像有越界

爱疯

Dim d As Object
Sub test()    '学习后的
    Dim f, z, arr, i
    i = Cells(Rows.Count, 1).End(xlUp).Row
    z = Range("B2:B" & i)
    f = Range("A2:A" & i)
    ReDim arr(1 To UBound(f), 1 To 1)
    Set d = CreateObject("scripting.dictionary")
    '向下查询，key是父，一父可能多子
    For i = 1 To UBound(arr)
        '可用嵌套字典或字符串累计，key中的key是其子
        If Not d.exists(f(i, 1)) Then Set d(f(i, 1)) = CreateObject("scripting.dictionary")
        d(f(i, 1))(z(i, 1)) = ""
    Next i
    '传入父，直到递归的结果不是父
    For i = 1 To UBound(arr)
        arr(i, 1) = dg(f(i, 1))
    Next i
    Range("c2").Resize(UBound(arr)) = arr
End Sub
'递归
Function dg(x) As Integer
    Dim k
    If d.exists(x) Then      '是父吗？
        For Each k In d(x).keys    '传入x的所有子，继续递归。
            dg = dg + dg(k) + 1
        Next
    Else
        dg = 0    '说明x是底层，结束递归。
    End If
End Function
dg3.rar (11.5 KB, 下载次数: 4)

2016-9-10 12:51 上传

点击文件名下载附件




为方便修改，用3个数组。

雄鹰2013

爱疯 发表于 2016-9-10 12:51
Dim d As Object
Sub test()    '学习后的
    Dim f, z, arr, i

不用递归可以解决吗

雄鹰2013

Sub 循环2()
Dim arr, brr()
Set d = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
     d(arr(i, 1)) = arr(i, 2) '父子对应
Next i
For i = 2 To UBound(arr)
     If Not dd.exists(arr(i, 1)) Then
        n = n + 1
        dd(arr(i, 1)) = n
        ReDim Preserve brr(1 To 2, 1 To n)
    End If
        k = 0
        t = arr(i, 2)
        Do While Len(t)
           If d.exists(t) Then
              k = k + 1: t = d(t)
           Else
              k = k + 1
              brr(1, dd(arr(i, 1))) = arr(i, 1)
              brr(2, dd(arr(i, 1))) = k + brr(2, dd(arr(i, 1)))
              Exit Do
           End If
        Loop
Next i
[d1].CurrentRegion.Offset(1) = ""
[d2].Resize(n, 2) = Application.Transpose(brr)
End Sub

爱疯

'学习改自 7楼 pengyx的方法
http://www.excelpx.com/thread-370343-1-1.html 7楼
Sub test()
    i = [a65536].End(3).Row
    f = Range("a2:a" & i)
    z = Range("b2:b" & i)
    ReDim ar(1 To UBound(z), 1 To 1)

    For i = 1 To UBound(f)
        For j = 1 To UBound(f)
            If f(i, 1) = f(j, 1) Then
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                '求一个儿子及后代的个数
                temp = z(j, 1): k = 0: Child = 1
                Do Until k > UBound(f)   'k > UBound(f)，表示全部比较过
                    For k = 1 To UBound(z)
                        If temp = f(k, 1) Then
                            Child = Child + 1
                            temp = z(k, 1)    '子变父
                            Exit For    '回头
                        End If
                    Next k
                Loop
                ar(i, 1) = ar(i, 1) + Child    '累计到该儿子的父里
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            End If
        Next j
    Next i
    Range("c2").Resize(UBound(z), 1) = ar
End Sub

dg4.rar (7.83 KB, 下载次数: 2)

2016-9-12 16:39 上传

点击文件名下载附件