vb 遍历 目录

给一个笨笨的办法，使用 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