EDIT：更新答案以将分组更改为above，并更正错误缩进和分组行的条件。
所以这是一个有趣的问题。除了实际的解决方案之外，我还有一些其他提示，我通常会在我的代码中包含这些提示，我也会提到这些提示。我的解决方案也非常快。当我解析 C:\Program Files\ 目录树（18,017 个文件）时，它在 5 秒内运行。
- 将变量声明为尽可能接近首次使用它们的位置。这样可以更轻松地确定变量类型和定义，还有助于对代码进行功能分组。
- 然后可以将这些逻辑组在功能上隔离为单独的功能和子。这将使您的代码的主要逻辑更容易在一个快速视图中掌握，而不是要求读者（可能在几个月内YOU）重新阅读大型逻辑部分并将其消化为了理解它。
在我的示例代码中，我从三个快速函数开始，它们可以准确地告诉您发生了什么：
Dim rootFolder As String
rootFolder = SelectFolder
Dim pathArray As Variant
pathArray = GetAllFiles(rootFolder)
Dim folderGroups As Object
Set folderGroups = BuildFolderDictionary(pathArray)
第一个功能很简单，并且紧跟您选择根文件夹的方法：
Private Function SelectFolder() As String
'--- returns the user-selected folder as a string
Dim objShell As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 17)
If Not objFolder Is Nothing Then
SelectFolder = objFolder.self.path
End If
End Function
下一个函数 (GetAllFiles) 也使用您的方法，但不是将结果直接放入工作表中，而是将结果保存在基于内存的数组中（在此答案的底部，我将整个模块包含在用于稍后复制/粘贴的单个代码块）：
Private Function GetAllFiles(ByVal rootPath As String, _
Optional onlyFolders As Boolean = False) As Variant
'--- returns a sorted array of all filepaths in the given directory path
Dim dirOptions As String
If onlyFolders Then
dirOptions = """ /a:d-h-s /b /s"
Else
dirOptions = """ /a:-h-s /b /s"
End If
Dim fOut() As String
fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & _
rootPath & _
dirOptions).StdOut.ReadAll, _
vbNewLine)
QuickSort fOut, LBound(fOut), UBound(fOut)
'--- the pathArray skips the first position from the fOut array
' because it's always blank, but add the root folder as the first entry
Dim pathArray As Variant
ReDim pathArray(1 To UBound(fOut) + 1, 1 To 1)
pathArray(1, 1) = rootPath
Dim i As Long
For i = 2 To UBound(fOut) + 1
pathArray(i, 1) = fOut(i - 1)
Next i
GetAllFiles = pathArray
End Function
基于内存的数组比使用Cells 或Ranges 直接在工作表外工作要快得多。
下一个函数 (BuildFolderDictionary) 使用路径数组并用于构建文件夹层次结构中唯一文件夹的列表 (Dictionary)。在此过程中，它还会创建子文件夹包含的行的“跨度”。这将在以后非常有用。请记住，我们在内存中执行所有这些操作，因此速度很快。
Private Function BuildFolderDictionary(ByRef paths As Variant) As Object
Dim folders As Object
Set folders = CreateObject("Scripting.Dictionary")
'--- scan all paths and create a dictionary of each folder and subfolder
' noting which items (rows) map into each dictionary
Dim i As Long
For i = LBound(paths) To UBound(paths)
Dim folder As String
Dim pos1 As Long
If Not IsEmpty(paths(i, 1)) Then
pos1 = InStrRev(paths(i, 1), "\") 'find the last folder separator
folder = Left$(paths(i, 1), pos1)
If Not folders.Exists(folder) Then
'--- new (sub)folder, create a new entry
folders.Add folder, CStr(i) & ":" & CStr(i)
Else
'--- extisting (sub)folder, add to the row range
Dim rows As String
rows = folders(folder)
rows = Left$(rows, InStr(1, rows, ":"))
rows = rows & CStr(i)
folders(folder) = rows
End If
End If
Next i
'--- final fixup: the root folder group should always encompass all
' the entries (runs from the second row to the end)...
' and we'll also determine the indent level using the first entry
' as the baseline (level 1). stored as "rows,level" e.g. "2:7,1"
Dim rootSlashes As Long
rootSlashes = Len(root) - Len(Replace(root, "\", "")) - 1
folders(root) = "2:" & UBound(paths) & ",1"
Dim slashes As Long
folder = folders.Keys
For i = 1 To UBound(folder)
slashes = Len(folder(i)) - Len(Replace(folder(i), "\", ""))
folders(folder(i)) = folders(folder(i)) & "," & _
CStr(slashes - rootSlashes)
Next i
For Each folder In folders
Debug.Print folder & " - " & folders(folder)
Next folder
Set BuildFolderDictionary = folders
End Function
最后两部分是将内存数组（文件路径）复制到工作表...
Const START_ROW As Long = 6
Dim pathRange As Range
Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray) + 1, 1)
pathRange = pathArray
然后应用行的缩进和分组。我们正在使用我们创建的文件夹组字典，其中已经为我们很好地定义了所有子文件夹行...
Const MAX_GROUP_LEVEL As Long = 8
Dim rowGroup As Variant
Dim level As Long
Dim folderData As Variant
Dim theseRows As String
For Each rowGroup In folderGroups
folderData = Split(folderGroups(rowGroup), ",")
theseRows = folderData(0)
level = folderData(1)
With pathRange.rows(theseRows)
.IndentLevel = level
If level < MAX_GROUP_LEVEL Then
.Group
End If
End With
Next rowGroup
（我在测试过程中遇到了一个问题，当程序错误的组级别超过 8。所以我在逻辑中设置了一个限制以防止错误。）
所以现在，整个模块在一个块中：
Option Explicit
Public Sub ShowFilePaths()
Dim rootFolder As String
rootFolder = SelectFolder
If rootFolder = vbNullString Then Exit Sub
'--- quick fixup if needed
rootFolder = rootFolder & IIf(Right$(rootFolder, 1) = "\", vbNullString, "\")
Dim pathArray As Variant
pathArray = GetAllFiles(rootFolder)
Dim folderGroups As Object
Set folderGroups = BuildFolderDictionary(rootFolder, pathArray)
'--- when debugging, this block just clears the worksheet to make it
' easier to rerun and test the code
On Error Resume Next
With Sheet1
.UsedRange.ClearOutline
.UsedRange.Clear
.Outline.SummaryRow = xlAbove
End With
Err.Clear
On Error GoTo 0
'--- copy the array to the worksheet
Const START_ROW As Long = 6
Dim pathRange As Range
Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray), 1)
pathRange = pathArray
'------ now apply the indention levels to each line on the sheet
' and group the same rows
Const MAX_GROUP_LEVEL As Long = 8
Dim rowGroup As Variant
Dim level As Long
Dim folderData As Variant
Dim theseRows As String
For Each rowGroup In folderGroups
folderData = Split(folderGroups(rowGroup), ",")
theseRows = folderData(0)
level = folderData(1)
With pathRange.rows(theseRows)
.IndentLevel = level
If level < MAX_GROUP_LEVEL Then
.Group
End If
End With
Next rowGroup
End Sub
Private Function SelectFolder() As String
'--- returns the user-selected folder as a string
Dim objShell As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 17)
If Not objFolder Is Nothing Then
SelectFolder = objFolder.self.Path
End If
End Function
Private Function GetAllFiles(ByVal rootPath As String, _
Optional onlyFolders As Boolean = False) As Variant
'--- returns a sorted array of all filepaths in the given directory path
Dim dirOptions As String
If onlyFolders Then
dirOptions = """ /a:d-h-s /b /s"
Else
dirOptions = """ /a:-h-s /b /s"
End If
Dim fOut() As String
fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & _
rootPath & _
dirOptions).StdOut.ReadAll, _
vbNewLine)
QuickSort fOut, LBound(fOut), UBound(fOut)
'--- the pathArray skips the first position from the fOut array
' because it's always blank, but add the root folder as the first entry
Dim pathArray As Variant
ReDim pathArray(1 To UBound(fOut) + 1, 1 To 1)
pathArray(1, 1) = rootPath
Dim i As Long
For i = 2 To UBound(fOut) + 1
pathArray(i, 1) = fOut(i - 1)
Next i
GetAllFiles = pathArray
End Function
Private Function BuildFolderDictionary(ByVal root As String, _
ByRef paths As Variant) As Object
Dim folders As Object
Set folders = CreateObject("Scripting.Dictionary")
'--- scan all paths and create a dictionary of each folder and subfolder
' noting which items (rows) map into each dictionary
Dim folder As Variant
Dim i As Long
For i = LBound(paths) To UBound(paths)
Dim pos1 As Long
If Not IsEmpty(paths(i, 1)) Then
pos1 = InStrRev(paths(i, 1), "\") 'find the last folder separator
folder = Left$(paths(i, 1), pos1)
If Not folders.Exists(folder) Then
'--- new (sub)folder, create a new entry
folders.Add folder, CStr(i) & ":" & CStr(i)
Else
'--- extisting (sub)folder, add to the row range
Dim rows As String
rows = folders(folder)
rows = Left$(rows, InStr(1, rows, ":"))
rows = rows & CStr(i)
folders(folder) = rows
End If
End If
Next i
'--- final fixup: the root folder group should always encompass all
' the entries (runs from the second row to the end)...
' and we'll also determine the indent level using the first entry
' as the baseline (level 1). stored as "rows,level" e.g. "2:7,1"
Dim rootSlashes As Long
rootSlashes = Len(root) - Len(Replace(root, "\", "")) - 1
folders(root) = "2:" & UBound(paths) & ",1"
Dim slashes As Long
folder = folders.Keys
For i = 1 To UBound(folder)
slashes = Len(folder(i)) - Len(Replace(folder(i), "\", ""))
folders(folder(i)) = folders(folder(i)) & "," & _
CStr(slashes - rootSlashes)
Next i
For Each folder In folders
Debug.Print folder & " - " & folders(folder)
Next folder
Set BuildFolderDictionary = folders
End Function
Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
'--- from https://stackoverflow.com/a/152333/4717755
Dim P1 As Long, P2 As Long, Ref As String, TEMP As String
P1 = LB
P2 = UB
Ref = Field((P1 + P2) / 2)
Do
Do While (Field(P1) < Ref)
P1 = P1 + 1
Loop
Do While (Field(P2) > Ref)
P2 = P2 - 1
Loop
If P1 <= P2 Then
TEMP = Field(P1)
Field(P1) = Field(P2)
Field(P2) = TEMP
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If LB < P2 Then Call QuickSort(Field, LB, P2)
If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub