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

sandorn

wzsy2_mrf 发表于 2019-3-9 09:05

使用了一下，非常好，感谢！！！！

sandorn

micch 发表于 2019-3-9 10:19
不熟练递归，练习一下，结果排序只会最基础的，还不会多关键字排序

感谢，很好用的代码

micch

sandorn 发表于 2019-3-9 12:36
感谢，很好用的代码

我也是初学递归，还在琢磨中，能用就好

chis3

wzsy2_mrf 发表于 2019-3-9 09:05

看的一頭霧水,是否一定要用call 递归 才能完成這題目?

wzsy2_mrf

chis3 发表于 2019-3-9 13:00
看的一頭霧水,是否一定要用call 递归 才能完成這題目?

递归的你看不懂，非递归的你更看不懂了。不是一定要用递归，不过不用的话写起来有些烦琐，因为需要自己来管理回溯，但速度会更快。

一把小刀闯天下

sandorn 发表于 2019-3-9 10:33
首先非常感谢帮助！！各级均可能是多个，没有限定的单线，能否优化一下？

'再加字典，输出格式处理起来有点晕，试了一下好像差不多，，，

Option Explicit

Dim result, dic(2), lastpos

Sub test()
  Dim arr, i, j, key, t, m, n, flag As Boolean
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = Range("a2:b" & Cells(Rows.Count, "a").End(xlUp).Row)
  ReDim result(1 To UBound(arr, 1), 1 To 10 ^ 2) As String
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 1)
      If arr(i, 1) = arr(j, 2) Then Exit For
    Next
    If j = UBound(arr, 1) + 1 Then
      dic(0)(arr(i, 1)) = dic(0)(arr(i, 1)) + 1
    End If
  Next
  For Each key In dic(0).keys
    For i = 1 To dic(0)(key)
      flag = True
      For j = 1 To UBound(arr, 1)
        If arr(j, 1) = key Then
          m = m + 1: n = 1: t = arr(j, 2)
          If flag Then result(m, n) = key: flag = False
          arr(j, 1) = vbNullString: lastpos = m
          dic(1).RemoveAll: dic(2)(arr(j, 2)) = m
          Call rec(arr, arr(j, 2), m, n, t)
          n = n + 1: result(lastpos, n) = t
        End If
  Next j, i, key
  [s1].Resize(UBound(arr, 1), UBound(result, 2)) = result
End Sub

Function rec(arr, s, m, n, t)
  Dim i, j, tt
  For i = 1 To UBound(arr, 1)
    If s = arr(i, 1) Then
      If dic(1).exists(arr(i, 1)) Then
        dic(2)(arr(i, 1)) = dic(2)(arr(i, 1)) + 1
        result(dic(2)(arr(i, 1)), dic(1)(arr(i, 1)) + 1) = arr(i, 2)
        If m < dic(2)(arr(i, 1)) Then m = dic(2)(arr(i, 1))
        lastpos = lastpos + 1
      Else
        n = n + 1: dic(2)(arr(i, 1)) = lastpos
        dic(1)(arr(i, 1)) = n
        t = arr(i, 2)
        result(dic(2)(arr(i, 1)), dic(1)(arr(i, 1))) = arr(i, 1)
        result(dic(2)(arr(i, 1)), dic(1)(arr(i, 1)) + 1) = arr(i, 2)
      End If
      arr(i, 1) = vbNullString
      Call rec(arr, arr(i, 2), m, n, t)
    End If
  Next
End Function

飞天篮球猪

提供一个pq的递归解法，供参考：

1. = let fx=(m,n)=>if List.MatchesAll(m,each List.Last(_)=null) then #table(n,List.Transform(m,each List.FirstN(_,n)))
   
2.                 else @fx( List.TransformMany( m,
   
3.                                               (L)=>let a=List.Select(Table.ToRows(源),each _{0}=L{n})
   
4.                                                     in if a{0}?=null then {{}} else a,
   
5.                                               (x,y)=>x&{y{1}?}), n+1)
   
6.     in fx(Table.ToRows(Table.SelectRows(源,each not List.Contains(源[职员],[推荐人]))),1)

复制代码

我是HR

呵呵，看到好多老师都能递归，可惜小菜鸟的我实在理解不了递归的思路。
刚学习了数组和字典，用此方法 献丑了，希望老师指点下代码哦

我是HR

1. Sub 父子关系()
   
2.     Dim arr, dic, brr(1 To 10000), crr()
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     arr = [a1].CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & arr(i, 2)
   
9.     Next i
   
10.     i = 1
    
11.     For n = 2 To UBound(arr)
    
12.         If dic.exists(arr(n, 1)) Then
    
13.             h = h + 1
    
14.             brr(h) = arr(n, 1)
    
15.             Do While i <= h
    
16.                 xm = Mid(brr(i), InStrRev(brr(i), "-") + 1)
    
17.                 If InStr(dic(xm), "|") Then
    
18.                     ms = Split(Mid(dic(xm), 2), "|")
    
19.                     For x = 0 To UBound(ms)
    
20.                         h = h + 1
    
21.                         brr(h) = brr(i) & "-" & ms(x)
    
22.                         Cells(h, "m") = brr(h)
    
23.                     Next x
    
24.                 End If
    
25.                 i = i + 1
    
26.                 If dic.exists(xm) Then dic.Remove xm
    
27.             Loop
    
28.         End If
    
29.     Next n
    
30.     dic.RemoveAll
    
31.     For i = 1 To h
    
32.         dic(brr(i)) = ""
    
33.     Next i
    
34.     For Each k In dic.keys
    
35.         For i = 1 To h
    
36.             If InStr(brr(i), k & "-") Then
    
37.                 dic.Remove k
    
38.                 Exit For
    
39.             End If
    
40.         Next i
    
41.     Next
    
42.     x = 0
    
43.     ReDim crr(1 To dic.Count, 1 To 20)
    
44.     For Each k In dic.keys
    
45.         x = x + 1
    
46.         For j = 0 To UBound(Split(k, "-"))
    
47.             crr(x, j + 1) = Split(k, "-")(j)
    
48.         Next j
    
49.     Next
    
50.     For j = 1 To 20
    
51.         For i = 1 To x - 1
    
52.             If Len(crr(i, j)) Then
    
53.                 For a = i + 1 To x
    
54.                     If Len(crr(a, j)) And crr(a, j) = crr(i, j) Then crr(a, j) = ""
    
55.                 Next a
    
56.             End If
    
57.         Next i
    
58.     Next j
    
59.     [o1].Resize(x, 20) = crr
    
60.     Set dic = Nothing: Set d = Nothing
    
61.     Application.ScreenUpdating = True
    
62. End Sub

复制代码

小花鹿

参与一下：
Sub test()
Dim ar, i&, d, d1, d2, dk, br, myr&, myc&
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ar = Range("a1").CurrentRegion
For i = 2 To UBound(ar)
    d(ar(i, 1)) = d(ar(i, 1)) & "|" & ar(i, 2)
    d1(ar(i, 1)) = ""
Next i
For i = 2 To UBound(ar)
    If d1.exists(ar(i, 2)) Then
        d1.Remove (ar(i, 2))
    End If
Next i
ReDim br(1 To i, 1 To i)
dk = d1.keys
myr = 1
For i = 0 To UBound(dk)
    Call digui(dk(i), d, br, myr, 1, myc)
Next i
Range("m2").Resize(myr, myc) = br
End Sub
Sub digui(s, d, br, myr, c, myc)
Dim ds, i&
If c > myc Then myc = c
br(myr, c) = s
If d(s) = "" Then
    myr = myr + 1
    Exit Sub
End If
ds = Split(d(s), "|")
For i = 1 To UBound(ds)
    Call digui(ds(i), d, br, myr, c + 1, myc)
Next i
End Sub