Const TR_LEVEL_MARK = "+"Const TR_COL_INDEX = "A"Const TR_COL_LEVEL = "E"Const TR_COL_NAME = "C"Const TR_COL_COUNT = "D"Const TR_COL_TREE_START = "F"Const TR_ROW_HEIGHT = 23Const TR_COL_LINE_WIDTH = 3Const TR_COL_BOX_MARGIN = 4Sub getpath()Dim obj As Object, i&, arrf$(), mf&, n$(), d As Object

Range("A2:C1000").ClearContents '清空A2：C1000列 On Error Resume Next Dim shell As Variant Set shell = CreateObject("Shell.Application") Set filePath = shell.BrowseForFolder(&O0, "选择文件夹", &H1 + &H10, "") '获取文件夹路径地址 手动选择 Set shell = Nothing If filePath Is Nothing Then '检测是否获得有效路径，如取消直接跳出程序 Exit Sub Else gg = filePath.Items.Item.Path End If Set obj = CreateObject("Scripting.FileSystemObject") '定义变量

Call GetFolders(gg, obj, arrf, mf, n) '获取路径

m = -1 With ActiveSheet For i = 1 To mf m = m + 1 Cells(m + 1, 1) = arrf(i) Cells(m + 1, 5) = "" For j = 1 To n(i) Cells(m + 1, 5) = "+" & Cells(m + 1, 5) Level = Cells(m + 1, 5) Next

Set fld = obj.getfolder(arrf(i)) For Each ff In fld.Files '遍历文件夹里文件 m = m + 1 Cells(m + 1, 1) = ff.Name Cells(m + 1, 2) = ff.Path Cells(m + 1, 3) = ff.Size Cells(m + 1, 4) = ff.DateCreated Cells(m + 1, 5) = Level & "+"

Next Next End With Call CalculationAndDrawTreeEnd Sub

Private Sub GetFolders(ByVal sPath$, Fso As Object, ByRef arrf$(), ByRef mf&, ByRef n$())

Dim SubFolder As Object

mf = mf + 1 ReDim Preserve arrf(1 To mf) arrf(mf) = sPath ReDim Preserve n(1 To mf) n(mf) = mf

For Each SubFolder In Fso.getfolder(sPath).SubFolders

Call GetFolders(SubFolder.Path, Fso, arrf, mf, n)

Next Set SubFolder = NothingEnd Sub

'===============================================================================' 堆栈在树形结构中使用的实例''-------------------------------------------------------------------------------' 本实例实现一下功能：' (1) 树形结构中，按级数汇总数量，即每级汇总该级下全部数量' (2) 按树形结构设置Excel的数据分组及分级显示' (3) 使用方框与连接线绘制树形，类似TreeView效果'-------------------------------------------------------------------------------' 原始数据中，有全部数形结构数据，各节点唯一的编号、能指示节点所在级数的符号、' 节点的名称、需要统计的数量。该树形结构各分支的级数不确定，仅在各分支的末梢节点有' 待统计的数量数据。'-------------------------------------------------------------------------------' 本代码采用字典对象模拟堆栈，对原始数据循环一次扫描完成统计计算并绘制树形图，' 可学习到堆栈、字典对象、结构图绘制、数据分组分级显示、代码操控单元格公式等多方面' 内容。' 本实例可应用于材料清单（BOM）的统计、公司结构绘制等多种实践。'===============================================================================

Sub CalculationAndDrawTree() Dim iMaxRow&, i&, j&, dic, aKeys, iLevelLast%, iLevelNow% '全部恢复

Application.ScreenUpdating = False '最大行号 iMaxRow = Cells(65536, 1).End(xlUp).Row '设置行高 Rows("1:" & iMaxRow).RowHeight = TR_ROW_HEIGHT '初始前一节点的级数 iLevelLast = 0 '设置字典对象以模拟堆栈，Key为行号，Item为对应的级数。也可以反过来用的... Set dic = CreateObject("Scripting.Dictionary") '循环自数据起始行始至数据结尾行加一止，多一行以收尾堆栈内最后剩余的节点 For i = 2 To iMaxRow + 1 If i = iMaxRow + 1 Then iLevelNow = 0 Else '获得当前节点级数，此例用B列加号数量判断 iLevelNow = UBound(Split(Range(TR_COL_LEVEL & i), TR_LEVEL_MARK)) '设置当前行的大纲级数，不影响SUBTOTAL函数的计算 Rows(i).OutlineLevel = iLevelNow End If '如果前一节点在堆栈内，且前一节点级数同当前节点，则将前一节点从堆栈内删除 If dic.exists(i - 1) Then If dic(i - 1) = iLevelNow Then dic.Remove i - 1 End If '判断当前节点和前一节点的级数关系 If iLevelNow > iLevelLast Then '当前节点级数大于前一节点，将当前节点压入堆栈 dic(i) = iLevelNow ElseIf iLevelNow < iLevelLast Then '当前节点级数小于前一节点，将堆栈内大于等于当前节点级数的项有堆栈顶始逐一弹出，并执行内容 '获得堆栈内记录的行号数组 aKeys = dic.keys '由堆栈顶始向堆栈底扫描 For j = UBound(aKeys) To LBound(aKeys) Step -1 '如扫描至记录的级数小于当前节点级数则退出扫描 If dic(aKeys(j)) < iLevelNow Then Exit For With Range(TR_COL_COUNT & aKeys(j)) '设置统计公式为：SUBTOTAL(9, 该级下所有行)，该函数自动忽略选中区域内含有SUBTOTAL公式的单元格 .Formula = "=SUBTOTAL(9, " & TR_COL_COUNT & aKeys(j) + 1 & ":" & TR_COL_COUNT & i - 1 & ")" '设置背景色和字体颜色 .Interior.ColorIndex = 33 - dic(aKeys(j)) .Font.ColorIndex = dic(aKeys(j)) + 1 End With '删除堆栈顶部项目 dic.Remove aKeys(j) Next '将当前节点压入堆栈 dic(i) = iLevelNow End If '记录当前节点为前一节点，供下一个循环使用 iLevelLast = iLevelNow '绘制当前节点框，并与父节点绘制连接线

Next '清空字典项并重置对象 dic.RemoveAll: Set dic = Nothing

Application.ScreenUpdating = TrueEnd Sub