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

mrgood88

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

2018-9-4 14:35 上传

点击文件名下载附件

联系电话	代理名称	代理等级	上级代理			结果(分级缩进不是空格)	管理人数(含自已)
	严三	3级	丁二			郑一(1级)	6
	丁二	2级	郑一			王二(2级)	1
	朱三	3级	丁二			丁二(2级)	3
	郑一	1级	无			严三(3级)	1
	马二	2级	郑一			朱三(3级)	1
	金一	1级	无			马二(2级)	1
	王二	2级	郑一			金一(1级)	1

ykqrs

先留个记号。。。。。。。。。。。。。。。。。等着学习对我来说，太难

微笑12345

留个记号，等学习

三坛老窖

楼主的这个问题，有无越级管理的情况，如1级直接管理3级，如果没有这种情况，可直接套用有关BOM应用的帖子或程序。论坛中这类帖子有很多。

lsdongjh

单一字典，递归运算，2级以下的管理人数，你自己处理

1. 
   
2. Sub Test()
   
3.     Dim shSource As Worksheet, rgResult As Range
   
4.     Dim arr As Variant
   
5.     Dim lngRow As Long, lngCol As Long
   
6.     Dim objDic As Object
   
7.     Dim strTemp As String
   
8.     Dim arrTop() As String, strName As String, lngCount As Long
   
9.     Dim strSplit() As String, arrResult() As String, intIndent As Integer
   
10.    
    
11.     Set shSource = Sheets("Sheet4")
    
12.     shSource.Range("G2:H" & Rows.Count).ClearContents
    
13.     Set rgResult = shSource.Range("G2")
    
14.     arr = shSource.Range("B2:D8")
    
15.     Set objDic = CreateObject("Scripting.Dictionary")
    
16.    
    
17.     For lngRow = LBound(arr) To UBound(arr)
    
18.         If objDic.Exists(arr(lngRow, 3)) Then
    
19.             objDic(arr(lngRow, 3)) = objDic(arr(lngRow, 3)) & "|" & arr(lngRow, 1) & "(" & arr(lngRow, 2) & ")"
    
20.         Else
    
21.             objDic(arr(lngRow, 3)) = arr(lngRow, 1) & "(" & arr(lngRow, 2) & ")"
    
22.         End If
    
23.     Next
    
24.    
    
25.     strTemp = objDic("无")
    
26.     arrTop = Split(strTemp, "|")
    
27.     '递归方式运算层级
    
28.     For lngRow = LBound(arrTop) To UBound(arrTop)
    
29.         strName = arrTop(lngRow)
    
30.         strTemp = GetLevlByDIc(strName, objDic, 0)
    
31.         strSplit = Split(strTemp, "|")
    
32.         lngCount = UBound(strSplit) + 1
    
33.         rgResult.Offset(0, 1).Value = lngCount
    
34.         For lngCol = LBound(strSplit) To UBound(strSplit)
    
35.             arrResult = Split(strSplit(lngCol), ",")
    
36.             intIndent = arrResult(1)
    
37.             rgResult.IndentLevel = intIndent
    
38.             rgResult.Value = arrResult(0)
    
39.             Set rgResult = rgResult.Offset(1, 0)
    
40.         Next
    
41.     Next
    
42.    
    
43.     MsgBox "OK"
    
44. End Sub
    
45. 
    
46. 
    
47. Function GetLevlByDIc(strNameAll As String, objDic As Object, intLevel As Integer) As String
    
48.     Dim strName As String
    
49.     Dim strTemp As String, strSplit() As String, strN As String
    
50.     Dim intI As Integer
    
51.     Dim strResult As String
    
52.    
    
53.     strName = Split(strNameAll, "(")(0)
    
54.     If objDic.Exists(strName) = False Then
    
55.         strResult = strResult & strNameAll & "," & intLevel
    
56.     Else
    
57.         strResult = strNameAll & "," & intLevel
    
58.         strTemp = objDic(strName)
    
59.         strSplit = Split(strTemp, "|")
    
60.         For intI = LBound(strSplit) To UBound(strSplit)
    
61.            strN = strSplit(intI)
    
62.             strResult = strResult & "|" & GetLevlByDIc(strN, objDic, intLevel + 1)
    
63.         Next
    
64.     End If
    
65.    
    
66.     GetLevlByDIc = strResult
    
67. End Function

复制代码

ykqrs

三坛老窖 发表于 2018-9-4 16:48
楼主的这个问题，有无越级管理的情况，如1级直接管理3级，如果没有这种情况，可直接套用有关BOM应用的帖子 ...

老窖老师，拜读过你用递归处理BOM的帖子，这道题目不知用递归如何处理？如果没有越级管理的情况，能否写一个让我学习一下，谢谢你！

lsdongjh

ykqrs

东拼西凑，终于写出一个，能得到结果，不过感觉需优化的东西太多

1. Option Explicit
   
2. Dim d, aa, n%, jg(), x%
   
3. Sub qq()
   
4. Dim i&, arr, j%, z$, z1, d1, r0%, j1%, y%, m%, t$
   
5. i = [b65536].End(xlUp).Row
   
6. arr = Range("b2:d" & i)
   
7. Set d = CreateObject("Scripting.Dictionary")
   
8. Set d1 = CreateObject("Scripting.Dictionary")
   
9. Range("g2:h100").ClearContents
   
10. For i = 1 To UBound(arr)
    
11. If arr(i, 3) = "无" Then
    
12. Set d(arr(i, 1)) = CreateObject("Scripting.Dictionary")
    
13. End If
    
14. Next
    
15. For Each aa In d.keys
    
16. x = 0: Erase jg: d1.RemoveAll
    
17. For i = 1 To UBound(arr)
    
18. If arr(i, 3) <> "无" Then
    
19. If Not d.exists(arr(i, 3)) Then
    
20. Set d(arr(i, 3)) = CreateObject("Scripting.Dictionary")
    
21. End If
    
22. d(arr(i, 3))(arr(i, 1)) = ""
    
23. End If
    
24. Next
    
25. m = d(aa).Count
    
26. If m = 0 Then
    
27. r0 = [g65536].End(xlUp).Row
    
28. Cells(r0 + 1, "g") = aa & "(1级)"
    
29. Cells(r0 + 1, "h") = 1
    
30. Else
    
31. Call digui(aa, 1, "")
    
32. r0 = [g65536].End(xlUp).Row
    
33. z = Join(jg, ",")
    
34. z1 = Split(z, ",")
    
35. For j = 0 To UBound(z1)
    
36. If Not d1.exists(z1(j)) Then d1(z1(j)) = ""
    
37. Next
    
38. For j = 0 To d1.Count - 1
    
39. z1 = Split(d1.keys()(j), "(")
    
40. x = Val(z1(1))
    
41. Cells(r0 + 1 + j, "g").IndentLevel = x - 1
    
42. Cells(r0 + 1 + j, "g") = d1.keys()(j)
    
43. Next
    
44. For j = r0 + 1 To [g65536].End(xlUp).Row
    
45. For j1 = j + 1 To [g65536].End(xlUp).Row + 1
    
46. If Cells(j1, "g") = "" Then
    
47. Exit For
    
48. Else
    
49. If Cells(j1, "g").IndentLevel > Cells(j, "g").IndentLevel Then
    
50. y = y + 1
    
51. Else
    
52. Exit For
    
53. End If
    
54. End If
    
55. Next
    
56. Cells(j, "h") = y + 1: y = 0
    
57. Next
    
58. End If
    
59. Next
    
60. End Sub
    
61. Sub digui(Pid, n, s)
    
62. Dim i&, key, temp2
    
63. If d.exists(Pid) Then
    
64. temp2 = s & Pid & "(" & n & "级" & ")" & ","
    
65. key = d(Pid).keys
    
66. For i = 0 To UBound(key)
    
67. If InStr(temp2, key(i) & "(" & n & "级" & ")" & ",") = 0 Then Call digui(key(i), n + 1, temp2)
    
68. Next
    
69. Else
    
70. x = x + 1
    
71. ReDim Preserve jg(1 To x)
    
72. jg(x) = s & Pid & "(" & n & "级" & ")"
    
73. End If
    
74. End Sub
    

复制代码

ykqrs

又要审核。。。。。。。。。。。。。。。 根据上级关系生成由高到低层级关系.rar (21.18 KB, 下载次数: 39)

2018-9-5 15:12 上传

点击文件名下载附件

ykqrs

lsdongjh 发表于 2018-9-5 13:28

能不能上个附件？我认真学一下思路