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
