excelhome中有关BOM的部分内容

yiyiyicz · 发表于 2015-1-11 09:27

Sub t02()
'** 添加引用 microsoft xml v6.0 **
Dim Arr, nrr
Dim Dic, K, T
Dim Tt As New MSXML2.DOMDocument, Rt As IXMLDOMElement, Ndt As IXMLDOMElement, Nlt As IXMLDOMNode
Dim Nlist As MSXML2.IXMLDOMNodeList
Dim Routelist As String, Routemax As Integer, Tempmax As Integer
Set Tt = CreateObject("msxml2.domdocument")
Tt.setProperty "SelectionLanguage", "XPath"
lastrow = Sheet1.Range("a65536").End(xlUp).Row
Arr = Sheet1.Range("a2:c" & lastrow)
Set Tt = New MSXML2.DOMDocument
Set Rt = Tt.createElement("xmltree")
Set Tt.documentElement = Rt '//xml树之根节点
'=== 建立xml树 ===
Set Ndt = Tt.createElement("s" & Arr(1, 1)) '//添加树形图根节点“1”。由于xml的原因，自然数前要加字母变为“s1”
Call Ndt.setAttribute("edge", "10") '//设定相邻两结点之间的边长（属性）
Call Ndt.setAttribute("route", "s1") '//设定路径属性，记录路径上的所有结点
Call Ndt.setAttribute("tleaf", "tt") '//设定叶结点属性，初始标注为叶结点
Call Ndt.setAttribute("branchedge", "0") '存叶结点之间的最大路径长度
Call Ndt.setAttribute("branchroute", "") '存叶结点之间的最大路径长度的结点编号集合
Rt.appendChild Ndt
For i = 1 To UBound(Arr) '添加所有的子节点
tempt = "s" & Arr(i, 1)
Set Nlist = Tt.getElementsByTagName(tempt)
If Nlist.Length > 1 Then MsgBox "结点重复": Exit Sub
Set Rt = Nlist.Item(0)
Rt.removeAttribute ("tleaf") '//删除标注为叶节点属性
Call Rt.setAttribute("fleaf", "ff") '//新增非叶结点的属性，是为非叶结点的标识
Set Ndt = Tt.createElement("s" & Arr(i, 2))
Rt.appendChild Ndt
Call Ndt.setAttribute("edge", Arr(i, 3)) '由根节点到叶结点的累加路径长度
Call Ndt.setAttribute("route", "s" & Arr(i, 2)) '结点编号（存结点编号集合）
Call Ndt.setAttribute("tleaf", "tt") '标识叶结点
Next i
'Tt.Save "F:\creatxml.xml"'##调试用
'=== 处理xml树，找最长路径 ===
Set Nlist = Tt.selectNodes("//*[@tleaf]") '列出叶叶结点集合，属性为tleaf的元素结点。此处为Xpath语句
'====== 逐层、逐个处理叶结点 ======
Do Until Nlist.Length = 1 '当只剩一个tleaf属性时，逐层、逐个处理叶结点过程结束
Set Dic = CreateObject("Scripting.Dictionary")
For Each Nlt In Nlist '该循环后，得到叶结点的父结点的子结点数量。如果叶结点的父结点的子结点数量多于叶结点的数量，暂不处理
Dic(Nlt.parentNode.nodeName) = Dic(Nlt.parentNode.nodeName) + 1 '叶结点的父结点出现的次数，即叶结点的父结点的子结点数量
Next
For Each Nlt In Nlist '该循环后，保留符合处理条件的叶结点的父结点
Set Nlist = Nlt.parentNode.childNodes '叶结点的兄弟结点集合
If Dic.Exists(Nlt.parentNode.nodeName) Then
If Not Dic(Nlt.parentNode.nodeName) = Nlist.Length Then '叶结点的父结点的子结点的数量不等于叶结点的父结点出现的次数
Dic.Remove (Nlt.parentNode.nodeName) '删除该父结点，因为它的子节点数量不等于叶结点数量
End If
End If
Next
K = Dic.keys
For Each k1 In K
Set Rt = Tt.getElementsByTagName(k1).Item(0) '找叶结点的父结点
If Not Rt Is Nothing Then
Set Nlist = Rt.childNodes
Routemax = 0
Tempmax = 0
'==== 累加结点间的路径长度，添加路径结点集合 ====
For i = 1 To Nlist.Length - 1 '两层循环为找最长路径
For j = i + 1 To Nlist.Length
Tempmax = CInt(Rt.childNodes(i - 1).Attributes(0).nodeValue) _
+ CInt(Rt.childNodes(j - 1).Attributes(0).nodeValue)
If Tempmax > Routemax Then
Routemax = Tempmax '最长路径值记入中间变量
Routelist = ""
Routelist = Rt.childNodes(i - 1).Attributes(1).nodeValue & Rt.childNodes(j - 1).Attributes(1).nodeValue '最长路径路过的结点
End If
Next j
Next i
If CInt(Tt.getElementsByTagName("s1").Item(0).Attributes(2).nodeValue) < Routemax Then '比较已有的
Tt.getElementsByTagName("s1").Item(0).Attributes(2).nodeValue = Routemax '最长路径值存入根结点属性中
Tt.getElementsByTagName("s1").Item(0).Attributes(3).nodeValue = Routelist '最长路径路过的结点存入根结点属性中
End If
Routemax = 0
Routelist = ""
'==== 累加根结点到叶结点间的路径长度，添加路径结点集合 ====
For i = 0 To Nlist.Length - 1
'MsgBox Rt.childNodes(i).Attributes(0).nodeValue & "," & Rt.childNodes(i).Attributes(0).nodeName & "," & Rt.childNodes(i).nodeName
If CInt(Rt.childNodes(i).Attributes(0).nodeValue) > Routemax Then
Routemax = Rt.childNodes(i).Attributes(0).nodeValue
Routelist = ""
Routelist = Rt.childNodes(i).Attributes(1).nodeValue
End If
Next i
Rt.Attributes(0).nodeValue = Rt.Attributes(0).nodeValue + Routemax
Rt.Attributes(1).nodeValue = Routelist & Rt.Attributes(1).nodeValue
'==== 删除处理过的叶节点并修改其父结点的非叶结点的标识为叶结点 ====
Rt.removeAttribute ("fleaf")
Call Rt.setAttribute("tleaf", "tt")
For i = 0 To Nlist.Length - 1
Set Ndt = Rt.childNodes(0) '注意：childNodes的Index只能设置为0
Call Ndt.parentNode.removeChild(Ndt)
Set Ndt = Nothing
Next i
End If
Next
Tt.Save "F:\creatxml.xml"
Set Nlist = Tt.selectNodes("//*[@tleaf]")
Set Dic = Nothing
Loop
'Tt.Save "F:\creatxml.xml"'##调试用
'比较"根节点到叶结点的累加路径长度"(edge)与"叶结点之间的最大路径长度"(branchedge)，谁大
If CInt(Rt.Attributes(0).nodeValue) > CInt(Rt.Attributes(2).nodeValue) Then
MsgBox Space(4) & "最大路径长度" & Chr(10) & Space(10) & Rt.Attributes(0).nodeValue _
& Chr(10) & Space(4) & "最大路径结点集合列表" & Chr(10) & Space(10) & Rt.Attributes(1).nodeValue
Else
MsgBox Space(4) & "最大路径长度" & Chr(10) & Space(10) & Rt.Attributes(2).nodeValue _
& Chr(10) & Space(4) & "最大路径结点集合列表" & Chr(10) & Space(10) & Rt.Attributes(3).nodeValue
End If
End Sub

复制代码

原帖链接
http://club.excelhome.net/thread-1163712-7-1.html

一种对树形图的分析

tom007 · 发表于 2015-2-4 22:42

真的是太好了，好好学习。争取早日做出自己的作品与大家共享。

sdbz001 · 发表于 2016-9-5 09:31

谢谢楼主，收下慢慢学习!

dongwengui1984 · 发表于 2016-9-27 13:57

非常好，慢慢学习，谢谢

blackttea1 · 发表于 2016-11-18 14:35

真的是太好了，好好学习。

23号人生 · 发表于 2017-2-25 00:58

学习中。。。。

wbjjzhu · 发表于 2017-6-8 15:17

还常好的资源贴子，留个记号学习。

02761752696 · 发表于 2017-10-14 10:33

谢谢分享学习

wsc771 · 发表于 2018-6-15 16:45

感谢分享..

fhb197999 · 发表于 2018-10-15 09:54

感谢分享，好好学习！

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

[分享] excelhome中有关BOM的部分内容

最新热点 /1