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 = 23
Const TR_COL_LINE_WIDTH = 3
Const TR_COL_BOX_MARGIN = 4
Sub 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 CalculationAndDrawTree
End 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 = Nothing
End 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 = True
End Sub
