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

答：执行"获取所有文件夹"，按提示 *** 作。文件夹清单会显示在工作表的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

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 ("D:\My Documents\"), ""

    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 & "*.xls")

        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

---