根据上级关系生成由高到低层级关系

lsdongjh

根据上级关系生成由高到低层级关系.rar (16.81 KB, 下载次数: 24)

2018-9-5 17:24 上传

点击文件名下载附件

lsdongjh

完整版，含人数计算： 根据上级关系生成由高到低层级关系.rar (19.74 KB, 下载次数: 135)

2018-9-5 18:05 上传

点击文件名下载附件

mrgood88

谢谢各位大侠,试验了下,当层关系太多7.8级时，这样显示效果也不直观，哪位高手能做成树状折叠或分级显示

ykqrs

lsdongjh 发表于 2018-9-5 18:06
完整版，含人数计算：

老师你好，能否把递归部分改成SUB过程，我试着改了一下没成功，谢谢你

lsdongjh

ykqrs 发表于 2018-9-6 09:36
老师你好，能否把递归部分改成SUB过程，我试着改了一下没成功，谢谢你

sub 不能回参。

ykqrs

lsdongjh 发表于 2018-9-6 12:40
sub 不能回参。

感谢你的回复，你的代码留待以后慢慢研究吧，我重新把我那个优化了一下，结果和你的一样。

1. Dim d, aa, x%, str$
   
2. Sub zz()
   
3. Dim i&, arr, j%, z1, r0%, j1%, y%
   
4. i = [b65536].End(xlUp).Row
   
5. arr = Range("b2:d" & i)
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Range("g2:h100").ClearContents
   
8. For i = 1 To UBound(arr)
   
9. If Not d.exists(arr(i, 3)) Then
   
10. Set d(arr(i, 3)) = CreateObject("Scripting.Dictionary")
    
11. End If
    
12. d(arr(i, 3))(arr(i, 1)) = "(" & arr(i, 2) & ")"
    
13. Next
    
14. For Each aa In d("无").keys
    
15. x = 0: str = ""
    
16. If Not d.exists(aa) Then
    
17. r0 = [g65536].End(xlUp).Row
    
18. Cells(r0 + 1, "g") = aa & d("无")(aa)
    
19. Cells(r0 + 1, "h") = 1
    
20. Else
    
21. Call digui(aa, 0, "", d("无")(aa))
    
22. r0 = [g65536].End(xlUp).Row
    
23. z1 = Split(str, ",")
    
24. For j = 0 To UBound(z1)
    
25. Cells(r0 + 1 + j, "g").IndentLevel = Val(Split(z1(j), "|")(1))
    
26. Cells(r0 + 1 + j, "g") = Split(z1(j), "|")(0)
    
27. Next
    
28. For j = 0 To UBound(z1) - 1
    
29. For j1 = j + 1 To UBound(z1)
    
30. If Val(Split(z1(j1), "|")(1)) > Val(Split(z1(j), "|")(1)) Then
    
31. y = y + 1
    
32. Else
    
33. Exit For
    
34. End If
    
35. Next
    
36. Cells(r0 + 1 + j, "h") = y + 1: y = 0
    
37. Next
    
38. Cells(r0 + 1 + j, "h") = y + 1: y = 0
    
39. End If
    
40. Next
    
41. End Sub
    
42. Sub digui(Pid, n, s, w)
    
43. Dim i&, key, temp2, sr%, sar
    
44. If d.exists(Pid) Then
    
45. temp2 = s & Pid & w & "|" & n & ","
    
46. key = d(Pid).keys
    
47. For i = 0 To UBound(key)
    
48. Call digui(key(i), n + 1, temp2, d(Pid)(key(i)))
    
49. Next
    
50. Else
    
51. If str = "" Then
    
52. str = s & Pid & w & "|" & n
    
53. Else
    
54. sar = Split(s & Pid & w & "|" & n & ",", ",")
    
55. For sr = 0 To UBound(sar)
    
56. If InStr(str, sar(sr)) = 0 Then str = str & "," & sar(sr)
    
57. Next
    
58. End If
    
59. End If
    
60. End Sub
    

复制代码

ykqrs

怎么回事？发一个贴一审核吗？谁能告诉我怎样才不用审核吗？

ykqrs

Dim d, aa, x%, str$
Sub zz()
Dim i&, arr, j%, z1, r0%, j1%, y%
i = [b65536].End(xlUp).Row
arr = Range("b2:d" & i)
Set d = CreateObject("Scripting.Dictionary")
Range("g2:h100").ClearContents
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 3)) Then
Set d(arr(i, 3)) = CreateObject("Scripting.Dictionary")
End If
d(arr(i, 3))(arr(i, 1)) = "(" & arr(i, 2) & ")"
Next
For Each aa In d("无").keys
x = 0: str = ""
If Not d.exists(aa) Then
r0 = [g65536].End(xlUp).Row
Cells(r0 + 1, "g") = aa & d("无")(aa)
Cells(r0 + 1, "h") = 1
Else
Call digui(aa, 0, "", d("无")(aa))
r0 = [g65536].End(xlUp).Row
z1 = Split(str, ",")
For j = 0 To UBound(z1)
Cells(r0 + 1 + j, "g").IndentLevel = Val(Split(z1(j), "|")(1))
Cells(r0 + 1 + j, "g") = Split(z1(j), "|")(0)
Next
For j = 0 To UBound(z1) - 1
For j1 = j + 1 To UBound(z1)
If Val(Split(z1(j1), "|")(1)) > Val(Split(z1(j), "|")(1)) Then
y = y + 1
Else
Exit For
End If
Next
Cells(r0 + 1 + j, "h") = y + 1: y = 0
Next
Cells(r0 + 1 + j, "h") = y + 1: y = 0
End If
Next
End Sub
Sub digui(Pid, n, s, w)
Dim i&, key, temp2, sr%, sar
If d.exists(Pid) Then
temp2 = s & Pid & w & "|" & n & ","
key = d(Pid).keys
For i = 0 To UBound(key)
Call digui(key(i), n + 1, temp2, d(Pid)(key(i)))
Next
Else
If str = "" Then
str = s & Pid & w & "|" & n
Else
sar = Split(s & Pid & w & "|" & n & ",", ",")
For sr = 0 To UBound(sar)
If InStr(str, sar(sr)) = 0 Then str = str & "," & sar(sr)
Next
End If
End If
End Sub

ykqrs

1. Dim d, aa, x%, str$
   
2. Sub zz()
   
3. Dim i&, arr, j%, z1, r0%, j1%, y%
   
4. i = [b65536].End(xlUp).Row
   
5. arr = Range("b2:d" & i)
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Range("g2:h100").ClearContents
   
8. For i = 1 To UBound(arr)
   
9. If Not d.exists(arr(i, 3)) Then
   
10. Set d(arr(i, 3)) = CreateObject("Scripting.Dictionary")
    
11. End If
    
12. d(arr(i, 3))(arr(i, 1)) = "(" & arr(i, 2) & ")"
    
13. Next
    
14. For Each aa In d("无").keys
    
15. x = 0: str = ""
    
16. If Not d.exists(aa) Then
    
17. r0 = [g65536].End(xlUp).Row
    
18. Cells(r0 + 1, "g") = aa & d("无")(aa)
    
19. Cells(r0 + 1, "h") = 1
    
20. Else
    
21. Call digui(aa, 0, "", d("无")(aa))
    
22. r0 = [g65536].End(xlUp).Row
    
23. z1 = Split(str, ",")
    
24. For j = 0 To UBound(z1)
    
25. Cells(r0 + 1 + j, "g").IndentLevel = Val(Split(z1(j), "|")(1))
    
26. Cells(r0 + 1 + j, "g") = Split(z1(j), "|")(0)
    
27. Next
    
28. For j = 0 To UBound(z1) - 1
    
29. For j1 = j + 1 To UBound(z1)
    
30. If Val(Split(z1(j1), "|")(1)) > Val(Split(z1(j), "|")(1)) Then
    
31. y = y + 1
    
32. Else
    
33. Exit For
    
34. End If
    
35. Next
    
36. Cells(r0 + 1 + j, "h") = y + 1: y = 0
    
37. Next
    
38. Cells(r0 + 1 + j, "h") = y + 1: y = 0
    
39. End If
    
40. Next
    
41. End Sub
    
42. Sub digui(Pid, n, s, w)
    
43. Dim i&, key, temp2, sr%, sar
    
44. If d.exists(Pid) Then
    
45. temp2 = s & Pid & w & "|" & n & ","
    
46. key = d(Pid).keys
    
47. For i = 0 To UBound(key)
    
48. Call digui(key(i), n + 1, temp2, d(Pid)(key(i)))
    
49. Next
    
50. Else
    
51. If str = "" Then
    
52. str = s & Pid & w & "|" & n
    
53. Else
    
54. sar = Split(s & Pid & w & "|" & n & ",", ",")
    
55. For sr = 0 To UBound(sar)
    
56. If InStr(str, sar(sr)) = 0 Then str = str & "," & sar(sr)
    
57. Next
    
58. End If
    
59. End If
    
60. End Sub
    

复制代码

ykqrs

Dim d, aa, x%, str$
Sub zz()
Dim i&, arr, j%, z1, r0%, j1%, y%
i = [b65536].End(xlUp).Row
arr = Range("b2:d" & i)
Set d = CreateObject("Scripting.Dictionary")
Range("g2:h100").ClearContents
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 3)) Then
Set d(arr(i, 3)) = CreateObject("Scripting.Dictionary")
End If
d(arr(i, 3))(arr(i, 1)) = "(" & arr(i, 2) & ")"
Next
For Each aa In d("无").keys
x = 0: str = ""
If Not d.exists(aa) Then
r0 = [g65536].End(xlUp).Row
Cells(r0 + 1, "g") = aa & d("无")(aa)
Cells(r0 + 1, "h") = 1
Else
Call digui(aa, 0, "", d("无")(aa))
r0 = [g65536].End(xlUp).Row
z1 = Split(str, ",")
For j = 0 To UBound(z1)
Cells(r0 + 1 + j, "g").IndentLevel = Val(Split(z1(j), "|")(1))
Cells(r0 + 1 + j, "g") = Split(z1(j), "|")(0)
Next
For j = 0 To UBound(z1) - 1
For j1 = j + 1 To UBound(z1)
If Val(Split(z1(j1), "|")(1)) > Val(Split(z1(j), "|")(1)) Then
y = y + 1
Else
Exit For
End If
Next
Cells(r0 + 1 + j, "h") = y + 1: y = 0
Next
Cells(r0 + 1 + j, "h") = y + 1: y = 0
End If
Next
End Sub
Sub digui(Pid, n, s, w)
Dim i&, key, temp2, sr%, sar
If d.exists(Pid) Then
temp2 = s & Pid & w & "|" & n & ","
key = d(Pid).keys
For i = 0 To UBound(key)
Call digui(key(i), n + 1, temp2, d(Pid)(key(i)))
Next
Else
If str = "" Then
str = s & Pid & w & "|" & n
Else
sar = Split(s & Pid & w & "|" & n & ",", ",")
For sr = 0 To UBound(sar)
If InStr(str, sar(sr)) = 0 Then str = str & "," & sar(sr)
Next
End If
End If
End Sub