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