求助：将逐条记录根据父子关系改为树状结构

小花鹿

micch 发表于 2019-3-14 10:39
明白了，多谢，就是无论如何都要退回到进入的那个位置，所以exit并不是退到主过程，而是退出当前层的递归 ...

理解正确，不管走多深，回来的时候都要一步一步的原路返回，返回的路线、步数和进入时完全一样

wzsy2_mrf

来个非递归版的，关键在于回溯信息控制，比递归难写许多

1. Option Explicit
   
2. Dim d, dp, arr
   
3. Sub buildTree()
   
4.     Dim i&, arr, rend&, mkey
   
5.     With Sheet2
   
6.         rend = .Range("A1").End(xlDown).Row
   
7.         arr = .Range("a2:b" & rend)
   
8.     End With
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Set dp = CreateObject("scripting.dictionary")
    
11.     For i = 1 To UBound(arr)
    
12.         If Not d.exists(arr(i, 1)) Then
    
13.             d(arr(i, 1)) = arr(i, 2)
    
14.             If arr(i, 2) <> "" Then dp(arr(i, 2)) = arr(i, 1)
    
15.         Else
    
16.             If arr(i, 2) <> "" Then
    
17.                 d(arr(i, 1)) = d(arr(i, 1)) & "++" & arr(i, 2)
    
18.                 dp(arr(i, 2)) = arr(i, 1)
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     For Each mkey In d.keys
    
23.         If dp(mkey) = "" Then d("root") = d("root") & "++" & mkey
    
24.     Next
    
25.     d("root") = Right(d("root"), Len(d("root")) - 2)
    
26. End Sub
    
27. Sub NodeSearchFDG(root As String)
    
28.     Dim workStack$(), top&, str$, mnode$, mr&, brr, crr, i&, mc&  'workstack工作栈,top栈顶变量
    
29.     top = 1: mnode = root: mr = 1: mc = 1
    
30.     ReDim Preserve workStack(0 To top)
    
31.     workStack(top - 1) = "root++1++1"
    
32.     Do While top >= 1
    
33.         arr(mr, mc) = mnode
    
34.         str = d(mnode)
    
35.         If str <> "" Then mc = mc + 1 Else mr = mr + 1
    
36.         brr = Split(str & "++", "++")
    
37.         For i = UBound(brr) To 0 Step -1 '倒写，保持顺序
    
38.             If brr(i) <> "" Then
    
39.                 top = top + 1
    
40.                 workStack(top - 1) = brr(i) & "++" & mc '压栈
    
41.                 If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
    
42.             End If
    
43.         Next
    
44.         If top > 0 Then
    
45.             crr = Split(workStack(top - 1), "++")
    
46.             mnode = crr(0):  mc = crr(1)
    
47.             top = top - 1 '弹栈
    
48.         End If
    
49.     Loop
    
50.    Erase brr, crr, workStack$
    
51. End Sub
    
52. Sub aa()
    
53. ReDim arr(1 To 1000, 1 To 20)
    
54. Call buildTree
    
55. Call NodeSearchFDG("root")
    
56. Range("M1").Resize(UBound(arr), UBound(arr, 2)).ClearContents
    
57. Range("M1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
58. Set d = Nothing: Set dp = Nothing: Erase arr
    
59. End Sub
    

复制代码

wzsy2_mrf

附件如下：

不知道为什么

19楼的非递归不是已经有代码了啊，没有多难么。感觉还是递归比较难理解

wzsy2_mrf

不知道为什么 发表于 2019-3-17 10:58
19楼的非递归不是已经有代码了啊，没有多难么。感觉还是递归比较难理解

那有那么简单，19楼是错误的，你加多一些数据看看

不知道为什么

wzsy2_mrf 发表于 2019-3-17 11:01
那有那么简单，19楼是错误的，你加多一些数据看看

嗯嗯，建议多放点数据测试下

wzsy2_mrf

19楼应该也是正确的，给他的辅助列和次序搞混了。

我是HR

wzsy2_mrf 发表于 2019-3-17 11:32
19楼应该也是正确的，给他的辅助列和次序搞混了。

呵呵，谢谢老师的肯定。正想着如何请教您呢。初学者，出错也很正常，需要老师们多指导。

wzsy2_mrf

不知道为什么 发表于 2019-3-17 10:58
19楼的非递归不是已经有代码了啊，没有多难么。感觉还是递归比较难理解

老实说，我理解不了他的代码。

chis3

剛寫了個,好像不用太複雜和長的代碼
看看,大神指點

Dim arr
Dim dic As Object
Dim dic2 As Object
Dim n As Integer

Sub main2()
    Dim k
    [F1].CurrentRegion.Clear
    arr = ActiveSheet.Range("a1").CurrentRegion
    Set dic = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If Not dic.exists(arr(i, 1)) Then
            Set dic(arr(i, 1)) = CreateObject("scripting.dictionary")
        End If
        dic(arr(i, 1))(arr(i, 2)) = ""
    Next
    n = 1
    For Each k In dic.keys
        If Not dic2.exists(k) Then
            Call Fa(k, 1)
        End If
    Next
    Set dic = Nothing: Set dic2 = Nothing
End Sub

Sub Fa(p, c)
    Dim j
    ActiveSheet.Cells(n, 5 + c) = p
    For Each j In dic(p).keys
        If dic.exists(j) Then
            dic2(j) = ""
            Call Fa(j, c + 1)
        Else
            ActiveSheet.Cells(n, 5 + c + 1) = j
            n = n + 1
        End If
    Next j
End Sub