一个有意思的字典，树形字典 TreeDic！

山中老人

更新3  差点忘了，一些结构的操作方法！


1、Public Function Copy(SourceBranch As TreeDic, Optional ByVal Key As Variant = Nothing) As Boolean'复制一个分支或根
    'SourceBranch=被复制的根或分支对象
    'Key=复制后，在新树上的主键(名称)

演示一下：
     Dim TD As New TreeDic     Dim sc As TreeDic: Set sc = TD("中国")("四川")
     Dim Brc As TreeDic
     Set Brc = sc("成都")("武侯区")
     Set Brc = sc("巴中")("江北区")
     Dim bz As TreeDic: Set bz = sc("巴中")
     TD.Name = "地球"
     Dim hj As TreeDic: Set hj = TD("中国")("胡建")
     Debug.Print TD.AllBranchPath
     Debug.Print "1========================"
     Call hj.Copy(bz)
     Debug.Print TD.AllBranchPath

输出:
地球/中国
地球/中国/四川
地球/中国/四川/成都
地球/中国/四川/成都/武侯区
地球/中国/四川/巴中
地球/中国/四川/巴中/江北区
地球/中国/胡建
1========================
地球/中国
地球/中国/四川
地球/中国/四川/成都
地球/中国/四川/成都/武侯区
地球/中国/四川/巴中
地球/中国/四川/巴中/江北区
地球/中国/胡建
地球/中国/胡建/巴中
地球/中国/胡建/巴中/江北区

2、Public Function Move(SourceBranch As TreeDic, Optional ByVal Key As Variant = Nothing) As Boolean'移动一个分支或根，可以跨树移动
演示一下：
     Dim TD As New TreeDic     Dim sc As TreeDic: Set sc = TD("中国")("四川")
     Dim Brc As TreeDic
     Set Brc = sc("成都")("武侯区")
     Set Brc = sc("巴中")("江北区")
     Dim bz As TreeDic: Set bz = sc("巴中")
     TD.Name = "地球"
     Dim hj As TreeDic: Set hj = TD("中国")("胡建")
     Debug.Print TD.AllBranchPath
     Debug.Print "1========================"
     Call hj.Move(bz) '
     Debug.Print TD.AllBranchPath

输出:
地球/中国
地球/中国/四川
地球/中国/四川/成都
地球/中国/四川/成都/武侯区
地球/中国/四川/巴中
地球/中国/四川/巴中/江北区
地球/中国/胡建
1========================
地球/中国
地球/中国/四川
地球/中国/四川/成都
地球/中国/四川/成都/武侯区
地球/中国/胡建
地球/中国/胡建/巴中
地球/中国/胡建/巴中/江北区

3、Public Sub Cut() '将分支从树上切下（变成独立的树）

4、Public Function Graft(DestinationBranch As TreeDic, Optional ByVal Key As Variant = Nothing) As Boolean'嫁接（将独立的树，插入到另一颗树上）
    'DestinationBranch=嫁接目的位置(分支或根)
    'Key=嫁接后，在新树上的主键(名称)

演示一下：
     Dim TD As New TreeDic
     Dim sc As TreeDic: Set sc = TD("中国")("四川")
     Dim Brc As TreeDic
     Set Brc = sc("成都")("武侯区")
     Set Brc = sc("巴中")("江北区")
     Dim bz As TreeDic: Set bz = sc("巴中")
     TD.Name = "地球"
     Dim hj As TreeDic: Set hj = TD("中国")("胡建")
     Debug.Print TD.AllBranchPath
     Debug.Print "-----"
     Debug.Print bz.AllBranchPath
     Debug.Print "1========================"
     Call bz.Cut
     Debug.Print TD.AllBranchPath
     Debug.Print "-----"
     Debug.Print bz.AllBranchPath
     Debug.Print "2========================"
     Call bz.Graft(hj)
     Debug.Print TD.AllBranchPath
     Debug.Print "-----"
     Debug.Print bz.AllBranchPath


输出:
地球/中国
地球/中国/四川
地球/中国/四川/成都
地球/中国/四川/成都/武侯区
地球/中国/四川/巴中
地球/中国/四川/巴中/江北区
地球/中国/胡建
-----
地球/中国/四川/巴中/江北区
1========================
地球/中国
地球/中国/四川
地球/中国/四川/成都
地球/中国/四川/成都/武侯区
地球/中国/胡建
-----
巴中/江北区
2========================
地球/中国
地球/中国/四川
地球/中国/四川/成都
地球/中国/四川/成都/武侯区
地球/中国/胡建
地球/中国/胡建/巴中
地球/中国/胡建/巴中/江北区
-----
地球/中国/胡建/巴中/江北区

5、Public Function Clone() As TreeDic '创建[根]/[分支]的独立副本。在[根]上执行将复制整个树；在[分支]上执行，复制的[分支]将独立成一颗树。

演示一下：'克隆 根    Dim TD As New TreeDic
    TD.Value("总人口") = 335
    Dim whq As TreeDic:
    Set whq = TD("中国")("四川")("成都")("武侯区")
    whq.Value("面积") = 76.56
    whq.Value("面积单位") = "平方公里"
    TD("中国")("四川").Value("人口") = 123456789
    Dim BZS As TreeDic: Set BZS = TD("中国")("四川")("巴中")
    BZS.Value("电话区号") = "0827"
    BZS("江北区").Value("邮政编码") = 636099
    Debug.Print TD.AllBranchValueTxt(False)
    Debug.Print "1================"
    Dim TD2 As TreeDic: Set TD2 = TD.Clone
    TD.Clear
    Debug.Print TD2.AllBranchValueTxt(False)

输出:
.总人口=335
/中国
/中国/四川
/中国/四川.人口=123456789
/中国/四川/成都
/中国/四川/成都/武侯区
/中国/四川/成都/武侯区.面积=76.56
/中国/四川/成都/武侯区.面积单位=平方公里
/中国/四川/巴中
/中国/四川/巴中.电话区号=0827
/中国/四川/巴中/江北区
/中国/四川/巴中/江北区.邮政编码=636099
1================
.总人口=335
/中国
/中国/四川
/中国/四川.人口=123456789
/中国/四川/成都
/中国/四川/成都/武侯区
/中国/四川/成都/武侯区.面积=76.56
/中国/四川/成都/武侯区.面积单位=平方公里
/中国/四川/巴中
/中国/四川/巴中.电话区号=0827
/中国/四川/巴中/江北区
/中国/四川/巴中/江北区.邮政编码=636099

演示一下：'克隆 分支        Dim TD As New TreeDic
    Dim BZS As TreeDic: Set BZS = TD("中国")("四川")("巴中")
    Debug.Print TD.AllBranchValueTxt(False)
    Debug.Print "1================"
    Dim BZS2 As TreeDic: Set BZS2 = BZS.Clone
    Debug.Print BZS.AllBranchValueTxt(False)
    Debug.Print "----"
    Debug.Print BZS2.AllBranchValueTxt(False)

山中老人

更新附件！ 树形分类统计4.rar (98.09 KB, 下载次数: 47)

2021-5-3 09:10 上传

点击文件名下载附件

树形分类统计5.rar (103.84 KB, 下载次数: 58)

2021-5-3 15:11 上传

点击文件名下载附件

xiaofan1999

山中老人 发表于 2021-5-3 09:10
更新附件！

居然还可以这么做，小弟受教了！！！

xiaofan1999

山中老人 发表于 2021-5-3 09:09
更新2 差点忘了，一些结构的操作方法！

太强大了！！！这种效果真好，一目了然！！！

likaiyihou

大神你是巴中的？如有机会希望能向你当面请教

山中老人

likaiyihou 发表于 2021-5-3 11:42
大神你是巴中的？如有机会希望能向你当面请教

不是！ 我丈母娘家在！

山中老人

更新4 发现一个Bug
在复杂使用环境中，VBA会莫名的自动调用  Class_Terminate 执行，导致部分数据丢失！

所以只好，用Delete 来替代它！

Public Sub Delete() '删除  将本身从树上删除


另外：
修改ValueDic 为 DataDic ，使用范围更广！


Public Property Get DataDic(Object As Boolean, Value As Boolean) As Scripting.Dictionary  '导出节点(根/分支)数据到字典
    'Object=True 导出包含对象
    'Value=True 导出包含值



树形分类统计6.rar (94.02 KB, 下载次数: 96)

2021-5-6 07:23 上传

点击文件名下载附件

xiaofan1999

山中老人 发表于 2021-5-6 06:17
更新4 发现一个Bug
在复杂使用环境中，VBA会莫名的自动调用  Class_Terminate 执行，导致部分数据丢失！
...

感谢大佬这么细致的指点！！！

nicktf

大佬牛逼！！！！

gwjkkkkk

有意思，学习了。