[求助]如何用VBA遍历指定目录下的所有子文件夹和文件

banolee

Sub test3()
Dim sFolder As String
Dim wb As Workbook
Dim i As Long
    With Application.FileSearch
        .NewSearch
        .LookIn = "F:\EXCEL"
        .SearchSubFolders = True
        .filename = "*.xls"
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                On Error Resume Next
                Cells(i, 1) = .FoundFiles(i)
            Next i
        Else
             MsgBox "Folder " & sFolder & " contains no required files"
        End If
     End With
End Sub

我用的是EXCEL2007，这是我从网上找到的一段代码（稍做修改），但无法运行。错误提示停留在这一句:With Application.FileSearch  说对象不支持该动作。我查了一下帮助，发现自 2003以来，对象模型的更改中将Application对象的FileSearch属性隐藏了。

第一个问题： FileSearch这种方法还有可能用于2007吗？如果可以，应该怎么用？

第二个问题： 如果不能用，有什么可靠用简单的编程思路可以实现将特定文件夹下（含全部子目录）的XLS文件的文件名（含路径）提取到本工作薄中来？

谢谢各位老师，大家费心了。

huangyun

FileSearch这种方法还有可能用于2007吗？

不能用了。

zldccmx

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

zldccmx

3楼使用的是代用工作表的办法，工作起来比较耗时。

我们可以使用数组或者词典来提速!

zldccmx

Sub Test() '使用双字典，旨在提高速度
    Dim MyName, Dic, Did, I, T, F, TT, MyFileName
    T = Time
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add ("D:\"), ""
    I = 0
    Do While I < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
    Did.Add ("文件清单"), ""    '以查找D盘下所有EXCEL文件为例
    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.xls")
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = "XLS文件清单" Then
            Sheets("XLS文件清单").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then
        Sheets.Add.Name = "XLS文件清单"
    End If
    Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
    TT = Time - T
    MsgBox Minute(TT) & "分" & Second(TT) & "秒"
End Sub

[此贴子已经被作者于2008-9-21 18:25:41编辑过]

YZLSZAJ

这个才是我要找到！！！

hongtao8000

xuexi!

yanjie

好贴，学习一下！

gljzyp

收藏了！学习学习！

mobuli

原帖由 zldccmx 于 2008-9-21 18:18 发表
Sub Test() '使用双字典，旨在提高速度&nbsp;&nbsp;&nbsp; Dim MyName, Dic, Did, I, T, F, TT, MyFileName&nbsp;&nbsp;&nbsp; T = Time&nbsp;&nbsp;&nbsp; Set Dic = CreateObject("Scripting.Dictionary")&nbsp;&n ...

很有参考性的代码