VBA自動獲取二級文件夾目錄

Sub FindFileName()
    ThisWorkbook.Worksheets(1).UsedRange.Delete '打開文件時清空所有單元格內容
    Dim DirectPath As String '定義父文件夾路徑
    Dim ChildDirectPath As String '定義子文件夾路徑
    DirectPath = ThisWorkbook.Path & "\" '將當前文件所在文件夾路徑賦值爲父文件夾路徑
    ChildDirectPath = Dir(DirectPath, vbDirectory) '獲取父文件夾中首文件名賦值爲子文件夾第一個檢索值
    Dim DirectArray() '定義獲取子文件夾路徑數組
    Dim i As Long '定義索引值爲i
    '進入循環，循環獲取父文件夾中所有文件名(含文件夾)
    Do While Len(ChildDirectPath) > 0
        If ChildDirectPath <> "." And ChildDirectPath <> ".." Then
            If ChildDirectPath Like "*.*" Then '當獲取子文件名帶有"."(即包含".",".."以及帶有後綴的文件，如.xls,.doc)時，跳過[也就是隻獲取文件夾名稱的意思]
            Else '否則
                ReDim Preserve DirectArray(i) '重定義數組範圍，並保留原始數組內容
                DirectArray(i) = ChildDirectPath '將獲取到的子文件夾名稱放入數組中
                i = i + 1 '索引值加1
            End If
        End If
        ChildDirectPath = Dir(, vbDirectory) '檢索下一個文件名
    Loop
    If (CStr(Join(DirectArray, "")) = "") = True Then '判斷獲取的數組是否爲空
        MsgBox "當前文件夾中不含子文件"
    Else '否則執行獲取子文件夾的內容
        Dim FileName As String '定義文件名
        Dim ColIndex As Long '定義Sheet表初始列號
        '進入循環
        For i = 0 To UBound(DirectArray)
            FileName = Dir(DirectPath & DirectArray(i) & "\*.*") '獲取子文件夾文件的絕對路徑賦值爲FileName
            ColIndex = 2 '每執行一次For循環，列號重置爲2
            ThisWorkbook.Worksheets(1).Cells(i + 1, ColIndex - 1) = Replace(DirectArray(i), ThisWorkbook.Path & "\", "") '首列名稱去掉路徑名只留下子文件夾名稱
            '進入子文件夾循環獲取文件名
            Do Until FileName = ""
                ThisWorkbook.Worksheets(1).Cells(i + 1, ColIndex) = FileName '將獲取到的文件名填入Sheet1中
                FileName = Dir '檢索下一個文件名
                ColIndex = ColIndex + 1 '列號加1
            Loop
        Next
    End If
End Sub