VBA中怎么遍历所选路径中所有文件夹及其子文件夹(多个子文件)，并返回所有的最底层的文件夹路径

Question

选择一个路径后，返回所有文件夹中的子文件夹及其子文件夹，也就是每个最下层的文件夹路径。文件夹层数没规律，新手，求解，谢谢各位了

Answer 1

答：执行"获取所有文件夹"，按提示操作。文件夹清单会显示在工作表的AB列中。

Sub 获取所有文件夹()
    Dim Directory As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "请选择一个文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            Directory = .SelectedItems(1)
        End If
    End With
    Cells.ClearContents
    Call RecursiveDir(Directory)
End Sub
Public Sub RecursiveDir(ByVal CurrDir As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim Filesize As Double
    Dim TotalFolders, SingleFolder
    Cells(1, 1) = "目录名"
    Cells(1, 2) = "日期/时间"
    Range("A1:B1").Font.Bold = True
    
    Set TotalFolders = CreateObject("Scripting.FileSystemObject").GetFolder(CurrDir).SubFolders
    Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
    Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileDateTime(CurrDir)
    If TotalFolders.Count <> 0 Then
        For Each SingleFolder In TotalFolders
            ReDim Preserve Dirs(0 To NumDirs) As String
            Dirs(NumDirs) = SingleFolder
            NumDirs = NumDirs + 1
        Next
    End If
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
End Sub

Answer 2

Sub Test()
    Dim MyName, Dic, Did, I, T, F, TT, MyFileName
    T = Time
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add ("C:\Users\Administrator\Desktop\VB.NET\"), ""
    I = 0
    Do While I < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
    Did.Add ("文件清单"), ""    '以查找D盘My Documents下所有EXCEL文件为例
    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.*")
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = "XLS文件清单" Then
            Sheets("XLS文件清单").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then
        Sheets.Add.Name = "XLS文件清单"
    End If
    Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
    TT = Time - T
    MsgBox Minute(TT) & "分" & Second(TT) & "秒"
End Sub