关于父子结构和树结构转化的问题

micch · 发表于 2023-2-24 09:11

Tree画图.zip (210.24 KB, 下载次数: 21)

micch · 发表于 2023-2-24 12:58

还是不熟练，先写了一个父子结构转树结构的代码，但是总觉得不是很通用，需要更好的方法。

''' 父子转标准表测试
Sub Test_DataTable()
Dim dF As New Dictionary
Dim dS As New Dictionary
With Sheet2 'ActiveSheet
temp = .Range("a1").CurrentRegion.Value
.Range("b:c").Sort .Range("b1"), xlAscending, , , , , , xlYes
ar = .Range("a1").CurrentRegion.Value
.Range("a1:c" & UBound(temp)).Value = temp
' .Range("e1:g" & UBound(ar)).Value = ar
For i = 2 To UBound(ar)
dF(ar(i, 2)) = dF(ar(i, 2)) & "|" & ar(i, 3)
dS(ar(i, 3)) = ar(i, 2)
Next
ReDim br(1 To UBound(ar), 1 To 11)
i = 0
For Each x In dS.Keys
If Not dF.Exists(x) Then '末级节点
i = i + 1
s = x: sx = x
Do While dS.Exists(s)
s = dS(s)
sx = s & "|" & sx
Loop
cr = Split(sx, "|")
For j = 0 To UBound(cr)
br(i, j + 2) = cr(j)
Next
br(i, 1) = i
End If
Next
.Range("h2:t65536").ClearContents
.Range("h2").Resize(UBound(br), UBound(br, 2)).Value = br
.Range("H1").CurrentRegion.Offset(0, 1).Sort .Range("i1"), xlAscending, .Range("j1"), , xlAscending, .Range("k1"), xlAscending, xlYes
End With
Set dS = Nothing
Set dF = Nothing
End Sub

复制代码

zpy2 · 发表于 2023-2-24 16:26

递归。。。。

js代码

micch · 发表于 2023-2-24 17:15

只需要一个节点和父节点，某个子节点，3个信息一组，自动生成树状图？？

我可惜不会转化成VBA，自己写也能写出来，但是第一不通用，第二代码循环太多，逻辑不够简洁。

micch · 发表于 2023-2-25 14:26

micch 发表于 2023-2-24 12:58
还是不熟练，先写了一个父子结构转树结构的代码，但是总觉得不是很通用，需要更好的方法。

从末级向父级倒推，得出的数据是乱序的，虽然输出后排序似乎也行，但是不如一次性得到有序的树结构方便。

论坛好多父子结构，树结构的帖子，看来这一类帖子都不吸引人了

时间的音符 · 发表于 2023-2-25 16:28

提示: 作者被禁止或删除内容自动屏蔽

micch · 发表于 2023-2-25 22:23

代码很简洁，感谢还都做了注释。我用了200多行，而且分3-4次循环才完成。递归还是太不熟练了，我好好学习一遍

micch · 发表于 2023-2-25 23:57

暂时先做到这一步，关于递归还需要好好理解一下。
现在只能算出固定位置，如果做树状图还需要计算相对位置。
画图的时候节点如何根据相邻节点来判断最佳位置，还想不好如何做。

micch · 发表于 2023-2-26 13:04

递归到末级的时候退出还是不太理解

Dim fD As Dictionary
Sub Father_SontoTree()
With ActiveSheet
ar = .Range("A1").CurrentRegion.Value
End With
''' 字典存储父子数据
Set fD = New Dictionary
For i = 2 To UBound(ar)
Father = ar(i, 2)
Son = ar(i, 3)
If fD.Exists(Father) Then
Else
Set fD(Father) = New Dictionary
End If
fD(Father).Add Son, Father
Next
[h:z].ClearContents
[h1:t1].Value = [{"No.","Level1","Level2","Level3","Level4","Level5","Level6","Level7","Level8","Level9","Level10","Level11","Level12"}]
''' 遍历字典输出，开始行，开始列，当前列，数据首列
ExportTree fD, 1, 8, 1, 8
End Sub
Function ExportTree(d As Variant, r0%, c0%, lastC%, firstC%)
For Each x In d.Keys ''' 字典中x是子节点
If fD.Exists(x) Then '''x同时是父节点,行+1，列+1
r0 = r0 + 1
c0 = c0 + 1
lastC = c0 ''' 记录父节点的列序号
Cells(r0, c0).Value = x ''' 输出到单元格
''' 父节点在fD中存在，所以继续对其下属子节点循环
ExportTree fD(x), r0, c0, lastC, firstC
fD.Remove x
Else ''' x是末级子节点
If c0 <= firstC Then Exit Function '''列位置退到初始列以下完成遍历
r0 = r0 + 1
c0 = lastC + 1 ''' 末级子节点列序号不再增加，上级父节点列+1
Cells(r0, c0).Value = x ''' 输出末级子节点
End If
Next
lastC = lastC - 1 ''' 当前最后一个末级子节点，列位置回退一列
c0 = lastC
End Function

复制代码

micch · 发表于 2023-2-26 19:57

之前两种写法都需要排序数据，乱序数据不合适，换一种写法

Sub Main_CreateTree()
Dim ar, Coll As Collection
''' 读入父子结构数据数组，一对一
ar = ReadFatherSon
''' 数据整理到节点集合
Set Coll = Father_SonToCollection(ar)
''' 输出节点数据到表格
PrintTree Coll, Range("h2")
End Sub
Function Father_SonToCollection(ar) As Collection
Dim fD As Dictionary, sD As Dictionary
Dim Father$, Son$, i&, j&, x
Set fD = New Dictionary
Set sD = New Dictionary
''' 父子关系读入字典
For i = 1 To UBound(ar)
Father = ar(i, 1)
Son = ar(i, 2)
If fD.Exists(Father) Then
Else
Set fD(Father) = New Dictionary
End If
fD(Father).Add Son, Father
sD.Add Son, Father
Next
''' 节点整理
Dim Tree As Collection, Node As ClassNode
Set Tree = New Collection
''' 根节点=============================================================pause
i = 0: j = 0
For Each x In fD.Keys
If Not sD.Exists(x) Then
i = i + 1 ''' 唯一编号
j = j + 1 ''' 层内编号
'''树编码，两位递进默认同一级不超过99个节点
Set Node = New ClassNode
Node.addDetail i, 1, 0, Format(j, "00"), x
Tree.Add Node, CStr(i)
DFSNode Tree, fD, fD(x), i, 1, Format(j, "00") & "01"
End If
Next
Set Father_SonToCollection = Tree
exitLine:
Set fD = Nothing
Set sD = Nothing
End Function
Private Function DFSNode(Tree As Collection, fD As Dictionary, _
d As Object, nCode&, Level&, strName$)
Level = Level + 1
fathercode& = nCode
Dim Node As ClassNode
Dim fatherNode As ClassNode
For Each x In d.Keys
nCode = nCode + 1
Set Node = New ClassNode
Node.addDetail nCode, Level, fathercode, strName, x
Set fatherNode = Tree.Item(CStr(fathercode))
fatherNode.Children.Add Node
Tree.Add Node, CStr(nCode)
If fD.Exists(x) Then ''' 不是末级节点，进入下一级节点
DFSNode Tree, fD, fD(x), nCode, Level, strName & "01"
Level = Level - 1
End If
strName = Left(strName, Len(strName) - 2) & _
Format(val(Right(strName, 2)) + 1, "00")
Next
End Function
Function PrintTree(Tree As Collection, rangeTopLeft As Range)
Dim ar(), x As ClassNode
n = Tree.Count
ReDim ar(1 To n, 1 To 20)
For Each x In Tree
r = r + 1
With x
br = Array(.Code, .text, .Level, .Parent, .ChildrenCount, "BM" & .Name)
For j = 0 To UBound(br)
ar(r, j + 1) = br(j)
Next
ar(r, j + .Level) = .text
End With
Next
rangeTopLeft.CurrentRegion.ClearContents
rangeTopLeft.Resize(n, UBound(ar, 2)).Value = ar
End Function

复制代码

''' Class Name : ClassNode
Public Code As Long ''' 节点编号，在全部节点中唯一
Public Level As Long ''' 所在层级
Public Name As String ''' ROOT_节点编号_所在层级_目录编码
Public text As String ''' 文本值
Public Parent As Long ''' 父节点的编号
Public Children As Collection
Public Property Get ChildrenCount() As Long
ChildrenCount = Children.Count
End Property
Public Function addDetail(code0&, level0&, parent0&, name0$, text0)
Code = code0
Level = level0
Parent = parent0
Name = name0
text = text0
End Function
Private Sub Class_Initialize()
Set Children = New Collection
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 关于父子结构和树结构转化的问题

评分

时间的音符时间的音符当前离线性别保密 UID 3708493 阅读权限 0 注册时间 2017-3-30 在线时间小时最后登录 1970-1-1 积分 787 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	发表于 2023-2-25 16:28 \| 显示全部楼层 [广告] ★Excel Home云课堂 - 专业的职场技能充电站★ ★Excel三大利器★ ★ 笨办法学VBA全系列★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报