VBA遍历文件夹常用有三种方法

时　间:2012-05-26 08:43:21
作　者:风行   ID：16058  城市：江阴
摘　要:VBA遍历文件夹常用有三种方法，这三种方法中,filesearch不适合2007和2010版本，而且速度比较慢，递归法速度也慢。只有用DIR加循环的方法，速度飞快。下面是三种方法的代码
正　文:

1、filesearch法
 
Sub test3()
Dim wb As Workbook
Dim i As Long
Dim t
t = Timer
    With Application.FileSearch '调用fileserch对象
        .NewSearch '开始新的搜索
        .LookIn = ThisWorkbook.path  '设置搜索的路径
        .SearchSubFolders = True '搜索范围包括 LookIn 属性指定的文件夹中的所有子文件夹
        .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 "没找到文件"
        End If
     End With
 MsgBox Timer - t
End Sub
 
     2、递归法
 
       Sub Test()
Dim iPath As String, i As Long
Dim t
t = Timer
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要查找的文件夹"
        If .Show Then
            iPath = .SelectedItems(1)
        End If
    End With
   
    If iPath = "False" or Len(iPath) = 0 Then Exit Sub
   
    i = 1
    Call GetFolderFile(iPath, i)
   MsgBox Timer - t
    MsgBox "文件名链接获取完毕。", vbOKOnly, "提示"
 
End Sub
 
Private Sub GetFolderFile(ByVal nPath As String, ByRef iCount As Long)
Dim iFileSys
'Dim iFile As Files, gFile As File
'Dim iFolder As Folder, sFolder As Folders, nFolder As Folder
     Set iFileSys = CreateObject("Scripting.FileSystemObject")
    Set iFolder = iFileSys.GetFolder(nPath)
    Set sFolder = iFolder.SubFolders
    Set iFile = iFolder.Files
 
    With ActiveSheet
        For Each gFile In iFile
           ' .Hyperlinks.Add anchor:=.Cells(iCount, 1), Address:=gFile.path, TextToDisplay:=gFile.Name
            iCount = iCount + 1
        Next
    End With
   
    '递归遍历所有子文件夹
    For Each nFolder In sFolder
        Call GetFolderFile(nFolder.path, iCount)
    Next
End Sub
 
     3、dir循环法
 
Sub Test() '使用双字典，旨在提高速度
    Dim MyName, Dic, Did, i, t, F, TT, MyFileName
       'On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If Not objFolder Is Nothing Then lj = objFolder.self.path & "\"
    Set objFolder = Nothing
    Set objShell = Nothing
 
    t = Time
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (lj), ""
    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

Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店