给一个笨笨的办法，使用 DIR!
'以查找D:\盘下所有EXCEL文件为例
Sub M_dir()'这是一个主模块，中间调用两人子模块，一个遍历指定目录下的所有文件夹，一个遍历文件夹下的所有EXCEL文件
代码
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error Resume Next
Sheets.Add.Name = " 路径 "
If Err.Number <> 0 Then
ActiveSheet.Delete
Sheets( " 路径 " ).Cells.Delete
Err.Clear: On Error GoTo 0
End If
Set Sh = Sheets( " 路径 " )
Sh.[a1] = " D:\ " ' 以查找D盘下所有EXCEL文件为例
i = 1
Do While Sh.Cells(i, 1 ) <> ""
dirdir (Sh.Cells(i, 1 ))
i = i + 1
Loop
On Error Resume Next
Sheets.Add.Name = " XLS文件 "
If Err.Number <> 0 Then
ActiveSheet.Delete
Sheets( " XLS文件 " ).Cells.Delete
Err.Clear: On Error GoTo 0
End If
Set sh2 = Sheets( " XLS文件 " )
sh2.Cells( 1 , 1 ) = " 文件清单 "
For Each cel In Sh.[a1].CurrentRegion
Call dirf(cel.Value)
Next
End Sub
Sub dirf(My_Path) ' 遍历文件夹下的所有EXCEL文件
Set sh2 = Sheets( " XLS文件 " )
mm = sh2.[a65536].End(xlUp).Row + 1
MyFilename = Dir(My_Path & " *.xl* " )
Do While MyFilename <> ""
sh2.Cells(mm, 1 ) = My_Path & MyFilename
mm = mm + 1
MyFilename = Dir
Loop
End Sub
Sub dirdir(MyPath) ' 遍历指定目录下的所有文件夹
Dim MyName
Set Sh = Sheets( " 路径 " )
MyName = Dir(MyPath, vbDirectory)
m = Sh.[a65536].End(xlUp).Row + 1
Do While MyName <> ""
If MyName <> " . " And MyName <> " .. " Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
Sh.Cells(m, 1 ) = MyPath & MyName & " \ "
m = m + 1
End If
End If
MyName = Dir
Loop
End Sub