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

sandorn

描述不清楚，看图片吧
数据量比较大，寻求帮助
工作簿1.zip (11.67 KB, 下载次数: 50)

2019-3-8 20:47 上传

点击文件名下载附件

micch

如果李四推荐的职员除了赵六还有其他人，放哪？？

小花鹿

感觉要用递归，先记个记号                                                                                   

wzsy2_mrf

先建树，后递归即可。

chis3

留個名字

wzsy2_mrf

1. Option Explicit
   
2. Dim d, dp, arr
   
3. Sub buildTree()
   
4.     Dim i&, j&, arr, m&, str$, k&, 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 st(mnode, mr&, mc&)
    
28.     Dim i&, str$, brr, str1$
    
29.     str = d(mnode)
    
30.     arr(mr, mc) = mnode
    
31.     If str = "" Then mr = mr + 1:    Exit Sub
    
32.     brr = Split(str & "++", "++")
    
33.     For i = 0 To UBound(brr)
    
34.         str1 = brr(i)
    
35.         If brr(i) <> "" Then Call st(brr(i), mr, mc + 1)
    
36.     Next
    
37. End Sub
    
38. 
    
39. Sub aa()
    
40. ReDim arr(1 To 1000, 1 To 20)
    
41. Call buildTree
    
42. Call st("root", 1, 1)
    
43. Range("M1").Resize(UBound(arr), UBound(arr, 2)).ClearContents
    
44. Range("M1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
45. Set d = Nothing: Set dp = Nothing: Erase arr
    
46. End Sub
    

复制代码

wzsy2_mrf

附件如下：

一把小刀闯天下

'假设从第二层开始都是单线联系的，，，

Option Explicit

Dim result

Sub test()
  Dim arr, i, j, dic, key, t, m, n, flag As Boolean
  Set dic = CreateObject("scripting.dictionary")
  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(arr(i, 1)) = dic(arr(i, 1)) + 1
    End If
  Next
  For Each key In dic.keys
    For i = 1 To dic(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
          Call rec(arr, arr(j, 2), m, n, t)
          n = n + 1: result(m, n) = t
        End If
  Next j, i, key
  [n2].Resize(m, 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
      n = n + 1: result(m, n) = arr(i, 1)
      arr(i, 1) = vbNullString: t = arr(i, 2)
      Call rec(arr, arr(i, 2), m, n, t)
    End If
  Next
End Function

micch

1. Dim d, brr, s, n, all
   
2. Sub tt()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion.Offset(1)
   
5.     For i = 1 To UBound(arr): d(arr(i, 2)) = arr(i, 1): Next
   
6.     all = Join(d.items, ",")
   
7.     ReDim brr(d.Count, 9) '结果数组,最高9级,可改大
   
8.         For Each x In d.keys
   
9.             If InStr(all, x) = 0 Then Call dg(x, "")
   
10.         Next
    
11.     With [f2].Resize(n + 1, 9) '输出
    
12.         .Value = brr
    
13.         .Cells(1).Resize(, 9) = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
    
14.         .Sort .Cells(1, 1), , .Cells(1, 2), , , .Cells(1, 3)
    
15.     End With
    
16.     For Each Rng In [f3].Resize(n, 9)
    
17.         If Rng.Value = Rng.Offset(-1).Value And Rng <> "" Then _
    
18.         s = s & "," & (Rng.Address)
    
19.     Next
    
20.     Range(Mid(s, 2)) = ""
    
21. End Sub
    
22. Function dg(x, s)
    
23.     If d.exists(x) Then
    
24.         s = x & " " & s: x = d(x)
    
25.         Call dg(x, s)
    
26.     Else
    
27.         s = x & " " & s: n = n + 1
    
28.         For i = 0 To UBound(Split(s)) - 1
    
29.             brr(n, i) = Split(s)(i)
    
30.         Next
    
31.     End If
    
32. End Function
    

复制代码

不熟练递归，练习一下，结果排序只会最基础的，还不会多关键字排序

sandorn

一把小刀闯天下 发表于 2019-3-9 09:10
'假设从第二层开始都是单线联系的，，，

Option Explicit

首先非常感谢帮助！！各级均可能是多个，没有限定的单线，能否优化一下？