Sub ListFile()
fpath = [A1]
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
Set d = CreateObject("Scripting.Dictionary")
d.Add fpath, ""
Zi = 1
i = 0
Do While Zi = 1 And i < d.Count
dpath = d.keys
fname = Dir(dpath(i), vbDirectory)
Do While fname <> ""
If fname <> "." And fname <> ".." Then
If GetAttr(dpath(i) & fname) = vbDirectory Then
d.Add (dpath(i) & fname & "\"), ""
End If
End If
fname = Dir
Loop
i = i + 1
Loop
leixing = InputBox(prompt:="Please输入查找文件后缀", Default:="xls")
leixing = "*." & leixing & "*"
For Each x In d.keys
fname = Dir(x & leixing)
Do While fname <> ""
ms1 = ms1 & fname & ","
ms2 = ms2 & x & fname & ","
fname = Dir
Loop
Next
If ms = "" Then ms = "没有符合要求的文件,"
Dim Jieguo
result1 = Application.Transpose(Split(ms1, ","))
result2 = Application.Transpose(Split(ms2, ","))
If UBound(d.keys) <> -1 Then
[A3].Resize(UBound(result1), 1) = result1
[B3].Resize(UBound(result2), 1) = result2
End If
Set d = Nothing
End Sub
代码分析，请查阅：
零基础学Excel VBA-WE011 【子目录文件名获取】
