|
|
很久以前我做工程师的时候，有这个BOM父子结构转树形结构的需求，当时候我在excelhome找到一个代码，这个代码是哪个大师的我现在真的忘记了，好像是Lee1982，如果错了，请这位大师求你的原谅，在这里我也要感谢你的分享。这个代码我用了一阵子，就开始研究它。但是感觉太复杂了，看不懂。就自己到w3school学习了xml的一些技术，修改了一下。原来的代码如下，我自己做了点注释。(不贴了，附件里面看吧，系统字数限制没法贴)我修改后的代码如下 ，这个是父子转树形
- Sub 父子结构() '本来是父子结构转换为树形结构
- Dim Arr, strA$
- Dim L1 As IXMLDOMNodeList, Tt As New MSXML2.DOMDocument60
- Arr = Sheets("FaS").Range("a1").CurrentRegion
- Set Rt = Tt.createElement("A") 'Tt 为最顶部，增加一个Rt的子项，Rt的名字为root
- Rt.setAttribute "LEVEL", 0: Rt.setAttribute "DES", "A" 'Rt中增加四个属性
- Rt.setAttribute "QTY", 1: Rt.setAttribute "TQTY", 1
- Tt.appendChild Rt: Set Rt = Nothing 'Rt死了以后,Tt中的数据还存在,所以这个应该是传地址
- For i = 2 To UBound(Arr) '这段循环的意义在于，讲原始数据表格的输入到Rt中，按照程序的意思，
- strA = "//*[@DES='" & Arr(i, 1) & "']" 'stra为xpath语言,这句话是寻找描述为arr(i,1)的数据
- Set L1 = Tt.selectNodes(strA) 'L1为一个列表,找到属性值为父亲的节点,然后创建一个RT,
- Debug.Print L1.Length
- For Each Lx In L1
- Set Rt = Tt.createElement(Arr(i, 2))
- Rt.setAttribute "LEVEL", Lx.Attributes(0).NodeValue + 1 'rt为子节点,然后将子节点按安装到L1中,L1虽然为列表,但是他里面只有一个数据.
- Rt.setAttribute "DES", Arr(i, 2)
- Rt.setAttribute "QTY", Arr(i, 3)
- Rt.setAttribute "TQTY", Arr(i, 3) * Lx.Attributes(3).NodeValue '这一列增加了计算总数量的计算公式
- Lx.appendChild Rt 'L1直接增加子几点,然后一直循环
- Set Rt = Nothing
- Next
-
- Next i
- '上面的程序完成以后,其实再XML中,一颗大树已经建立好了,
- Call 父子转树形(Tt)
-
- End Sub
- Private Function 父子转树形(Tt As MSXML2.DOMDocument60) '
- Dim Brr, Ac, Abc
- Set Abc = Tt.selectNodes("//*[@*]") '这句话是吧所有带有属性的节点全部找出来了，，按照常规的BOM格式输出出来。
- ReDim Brr(1 To Abc.Length, 1 To 4) 'Document 按照平时的BOM的需求全部排列出来
- nn = 1
- For Each Ac In Abc '这个XML中selectnodes的好处就是 选择以后,就直接按照BOM的结构选择出来了.
- Brr(nn, 1) = Ac.Attributes(0).NodeValue '第一列为 层级别 第二列为名字，第三列为数量
- Brr(nn, 2) = Ac.Attributes(1).NodeValue '也就是深度优先的一种历遍方式
- Brr(nn, 3) = Ac.Attributes(2).NodeValue
- Brr(nn, 4) = Ac.Attributes(3).NodeValue
- nn = nn + 1
- Next
- Range("G2").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
- End Function
- Sub 树形结构() '程序将树形结构转变为父子结构
- Dim Arr, strA$
- Dim LastNode As IXMLDOMElement, Tt As New MSXML2.DOMDocument60
- Dim Rt As IXMLDOMElement, St As IXMLDOMElement '变量定义,其实VBA中 XML的技术主要有,Element,Document,和Nodelist几种对象,
- Dim Nlist As IXMLDOMNodeList
- Arr = Sheets("FaS").Range("G1").CurrentRegion
- Set Rt = Tt.createElement("A") 'Tt 为最顶部，增加一个Rt的子项，Rt的名字为root
- Rt.setAttribute "LEVEL", 0 '建立几个需要的属性
- Rt.setAttribute "QTY", 1
- Rt.setAttribute "TQTY", 1
- Tt.appendChild Rt: Set Rt = Nothing '建立完了以后清除内存
- For i = 3 To UBound(Arr)
- Set St = Tt.createElement(Arr(i, 2)) '开始循环 ,建立第一个 名字直接为名称
- St.setAttribute "LEVEL", Arr(i, 1) '建立属性值
- St.setAttribute "QTY", Arr(i, 3) ''
- St.setAttribute "TQTY", Arr(i, 4) ''
- strA = "//*[@LEVEL=" & Arr(i, 1) - 1 & "]" ''在已经有的大树中选择属性值LEVEL的值为当前LEVEL-1的节点.
- Set Nlist = Tt.selectNodes(strA)
- Set LastNode = Nlist(Nlist.Length - 1) '这一句最关键,需要选择最后一个选择出来的节点.
- LastNode.appendChild St '将孩子插入
- Set LastNode = Nothing '内存清除
- Set St = Nothing '内存清除
- Next i
- Call 树形转父子(Tt)
- End Sub
- Private Function 树形转父子(Tt As MSXML2.DOMDocument60) 'Tt As MSXML2.DOMDocument
- Dim Ac As IXMLDOMElement, Abc As IXMLDOMNodeList
- Set Abc = Tt.selectNodes("//*[@*]") '将所有有属性的节点选择出来
- ReDim Brr(1 To Abc.Length - 1, 1 To 3)
- nn = 1
- For Each Ac In Abc
- If Ac.childNodes.Length > 0 Then '如果节点有孩子,将此节点和孩子一起打印出来
- For Each b In Ac.childNodes
- Brr(nn, 1) = Ac.BaseName
- Brr(nn, 2) = b.BaseName
- Brr(nn, 3) = b.Attributes(1).NodeValue
- nn = nn + 1
- Next
- End If
- Next
- Range("N2").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
- End Function
- '总结:
- '1. 感觉其实使用XML技术,主要是向建立大树,然后利用xml 中SelectNode方法可以直接选出前序遍历的顺序.
这个代码有个问题，就是太复杂了，xml技术很简单，但是xpath我觉的挺难的，网上的代码拿到vba中总是不好用，前段时间没事研究递归算法，发现使用递归来做这个转换是最简单的。
父子转树形的代码如下
- Private Arr, Level&, K&, Max&, Xrr
- Public Sub 父子转树递归() '本来是父子结构转换为树形结构
- Dim strA$
- Arr = Sheets("FaS2").Range("a1").CurrentRegion
- Max = UBound(Arr)
- ReDim Xrr(1 To 100, 1 To 3)
- strA = "A" '父级别
- Level = 0: K = 1
- Call 父子递归(strA)
- Sheets("FaS2").Range("G3").Resize(UBound(Xrr, 1), 3) = Xrr
- End Sub
- Private Function 父子递归(str$)
- Dim i&, strB$
- Level = Level + 1
- For i = 2 To Max
- If Arr(i, 1) = str Then
- Xrr(K, 1) = Level: Xrr(K, 2) = Arr(i, 2): Xrr(K, 3) = Arr(i, 3)
- K = K + 1: strB = Arr(i, 2)
- Call 父子递归(strB)
- Level = Level - 1
- End If
- Next i
- End Function
- Public Sub 树转父子递归() '本来是父子结构转换为树形结构
- Dim dicA As New Dictionary
- Dim dicB As New Dictionary '用来去重
- Dim Arr, K&, Max&, Xrr(1 To 100, 1 To 3)
- Arr = Sheets("FaS2").Range("G1").CurrentRegion
- dicA(0) = "A"
- For i = 3 To UBound(Arr)
- dicA(Arr(i, 1)) = Arr(i, 2)
- s = dicA(Arr(i, 1) - 1) & Arr(i, 2)
- dicB(s) = Array(dicA(Arr(i, 1) - 1), Arr(i, 2), Arr(i, 3))
- Next i
- it = dicB.Items
- a = Application.Transpose(it)
- b = Application.Transpose(a)
- Range("N2").Resize(UBound(b), UBound(b, 2)) = b
- End Sub
最后附上附件
|
评分
-
3
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-10-29 20:03
楼主
