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