VBA笔记——遍历文件夹(含子文件夹)方法

一、调用目标文件夹的方法

1、Application.FileDialog方法

Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker) '运行后出现标准的选择文件夹对话框        
        If .Show Then myPath = .SelectedItems(1) Else Exit Sub '如选中则返回=-1 / 取消未选则返回=0 
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & "" 
    '返回的是选中目标文件夹的绝对路径,但除了本地C盘、D盘会以"C:"形式返回外，其余路径无""需要自己添加 
End Sub

2、视窗浏览器界面选择目标文件夹

Sub ListFilesTest()
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
    If Not myFolder Is Nothing Then myPath$ = myFolder.Items.Item.Path Else MsgBox "Folder not Selected": Exit Sub
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    '同样返回的是选中目标文件夹的绝对路径,但除了本地C盘、D盘会以"C:"形式返回外，其余路径无""需要添加 
End Sub

二、仅列出所有文件

• 不包括 子文件夹、不包括子文件夹中的文件

Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    '以上选择目标文件夹以得到路径myPath
    MsgBox ListFiles(myPath)    
    '调用FSO的ListFiles过程返回目标文件夹下的所有文件名
End Sub

Function ListFiles(myPath$)
   Set fso = CreateObject("Scripting.FileSystemObject") '打开FSO脚本、建立FSO对象实例
   For Each f In fso.GetFolder(myPath).Files  '用FSO方法遍历指定文件夹内所有文件
      i = i + 1: s = s & vbCr & f.Name            '逐个列出文件名并统计文件个数 i
   Next
   ListFiles = i & " Files:" & s  '返回所有文件名的合并字符串
End Function

三、仅列出目标文件夹中所有子文件夹名

• 不包括目标文件夹中文件、不包括子文件夹中的文件或子文件夹

Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & "" 
    MsgBox ListFolders(myPath)
End Sub

Function ListFolders(myPath$)
   Set fso = CreateObject("Scripting.FileSystemObject")
   For Each f In fso.GetFolder(myPath).SubFolders
      j = j + 1: t = t & vbCr & f.Name
   Next
   ListFolders = j & " Folders:" & t
End Function

fso.GetFolder(myPath).Files
fso.GetFolder(myPath).SubFolders

四、遍历目标文件夹内所有文件、以及所有子文件夹中的所有文件

• 递归

Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    [a:a] = ""                    '清空A列
    Call ListAllFso(myPath)   '调用FSO遍历子文件夹的递归过程
    
End Sub

Function ListAllFso(myPath$) '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    '用FSO方法得到当前路径的文件夹对象实例 注意这里的【当前路径myPath是个递归变量】

    For Each f In fld.Files  '遍历当前文件夹内所有【文件.Files】
        [a65536].End(3).Offset(1) = f.Name '在A列逐个列出文件名
    Next

    For Each fd In fld.SubFolders  '遍历当前文件夹内所有【子文件夹.SubFolders】
        [a65536].End(3).Offset(1) = " " & fd.Name & ""  '在A列逐个列出子文件夹名
        Call ListAllFso(fd.Path)       '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
        '注意重点在这里： 继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
    Next
End Function

• 字典

Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    MsgBox "List Files:" & vbCr & Join(ListAllFsoDic(myPath), vbCr)
    MsgBox "List SubFolders:" & vbCr & Join(ListAllFsoDic(myPath, 1), vbCr)
End Sub

Function ListAllFsoDic(myPath$, Optional k = 0) '使用2个字典但无需递归的遍历过程
    Dim i&, j&
    Set d1 = CreateObject("Scripting.Dictionary") '字典d1记录子文件夹的绝对路径名    
    Set d2 = CreateObject("Scripting.Dictionary") '字典d2记录文件名 （文件夹和文件分开处理）

    d1(myPath) = ""           '以当前路径myPath作为起始记录，以便开始循环检查
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Do While i < d1.Count
    '当字典1文件夹中有未遍历处理的key存在时进行Do循环 直到 i=d1.Count即所有子文件夹都已处理时停止

        kr = d1.Keys '取出文件夹中所有的key即所有子文件夹路径 （注意每次都要更新）
        For Each f In fso.GetFolder(kr(i)).Files '遍历该子文件夹中所有文件 （注意仅从新的kr(i) 开始）
            j = j + 1: d2(j) = f.Name
           '把该子文件夹内的所有文件名作为字典Item项加入字典d2 (为防止文件重名不能用key属性)
        Next

        i = i + 1 '已经处理过的子文件夹数目 i +1 （避免下次产生重复处理）
        For Each fd In fso.GetFolder(kr(i - 1)).SubFolders '遍历该文件夹中所有新的子文件夹
            d1(fd.Path) = " " & fd.Name & "" 
            '把新的子文件夹路径存入字典d1以便在下一轮循环中处理
        Next
    Loop

    If k Then ListAllFsoDic = d1.Keys Else ListAllFsoDic = d2.Items
    '如果参数=1则列出字典d1中所有子文件夹的路径名 (如使用d1.Items则仅列出子文件夹名称不含路径)
    '如果参数=0则默认列出字典d2中Items即所有文件名 
End Function

• DIR

Sub ListAllDirDicTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    MsgBox Join(ListAllDirDic(myPath), vbCr) 'GetAllSubFolder's File 列出目标文件夹内含子文件夹内所有文件
    MsgBox Join(ListAllDirDic(myPath, 1), vbCr) 'GetThisFolder's File 列出目标文件夹内所有文件(不含子文件夹)
    
    MsgBox Join(ListAllDirDic(myPath, -1), vbCr) 'GetThisFolder's SubFolder 仅列出目标文件夹内的子文件夹
    MsgBox Join(ListAllDirDic(myPath, -2), vbCr) 'GetAllSubFolder 列出目标文件夹内含子文件夹的所有子文件夹
    
    MsgBox Join(ListAllDirDic(myPath, 1, "tst"), vbCr) 'GetThisFolder's SpecialFile 仅列出文件夹内含关键字文件
    MsgBox Join(ListAllDirDic(myPath, , "tst"), vbCr) 'GetAllSubFolder's SpecialFile 列出子文件夹内含关键字文件
    
End Sub

Function ListAllDirDic(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    '利用Dir方法、以及用2个字典分别记录子文件夹路径和文件名的文件搜寻方法。

    '第1参数【指定路径myPath】必选 为指定目标文件夹的绝对路径

    '第2参数【子文件夹模式sb】为可选 =奇数时只搜寻当前文件夹、=偶数时搜寻所有子文件夹
    '                                      该参数>=0时返回文件名、<0时返回文件夹路径名 
    '因此事实上第2参数可以设置这样四种模式：
    '  默认=0时，搜寻所有子文件夹并返回所有文件名
    '        =1时，搜寻当前文件夹并返回所有文件名 (不向下搜寻子文件夹)
    '        =-1时，搜寻当前文件夹并返回子文件夹路径名
    '        =-2时， 搜寻所有子文件夹并返回所有子文件夹路径名

    '第3参数【文件名指定特殊匹配字符SpFile】 可选，返回文件名时用此关键词过滤一下
    '默认留空时，返回全部文件名 （等于没有被过滤掉）
    ' = 某个关键字时，返回符合匹配（即含该关键字）的部分文件名 （有过滤掉不含关键字的文件名）
    ' = .xl 也可这样指定文件类型，返回匹配（该关键字指定文件类型）的部分文件名 （过滤掉其它类型文件名）
    
    Dim i&, j&, myFile$
    Set d1 = CreateObject("Scripting.Dictionary") '定义存放子文件夹路径的字典d1
    Set d2 = CreateObject("Scripting.Dictionary") '定义存放文件名的字典d2
    
    d1(myPath) = " '字典d1初始化记录目标文件夹路径名
    On Error Resume Next
    Do While i < d1.Count
        kr = d1.Keys  '从字典d1中更新提取所有子文件夹
        myFile = Dir(kr(i), vbDirectory) '用Dir方法遍历该子文件夹得到文件或文件夹名 注意从kr(i)开始避免重复
        Do While myFile <> "" 'Dir遍历直到返回空字符串 （即无未被遍历的文件或文件夹了）
            If myFile <> "." And myFile <> ".." Then '如果是"."或".."属性则不用处理
                If (GetAttr(kr(i) & myFile) And vbDirectory) = vbDirectory Then '判断是文件夹属性时
                    If Err.Number Then Err.Clear Else d1(kr(i) & myFile & "") = ""
                    '#52 文件名Err时忽略（一般为操作系统语言文字环境问题），否则字典d1记录该子文件夹路径
                Else '如果不是文件夹则为文件
                    If SpFile = "" Then '如未指定关键字
                        j = j +1: d2(j) = myFile '则所有文件名都作为Item项加入字典d2 (不能使用key防止重名文件)
                    Else '否则指定了关键字 
                        If InStr(myFile, SpFile) Then j = j +1: d2(j) = myFile
                        '则判断含有指定关键字以后才可作为Item项加入字典d2 (不能使用key防止重名文件)
                    End If
                End If
            End If
            myFile = Dir '用Dir方法继续搜寻下一个文件或子文件夹
        Loop
        If sb Mod 2 Then Exit Do Else i = i + 1
        '如果第2参数指定为奇数则不用继续检查子文件夹就可退出，
        '否则 i+1避免重复检查然后利用字典d1中的记录，继续检查下一个子文件夹直到全部子文件夹检查完毕
    Loop
    If sb >= 0 Or Len(SpFile) Then ListAllDirDic = d2.Items Else ListAllDirDic = d1.Keys
    '如果第2参数>=0或第3参数有指定则返回d2的Items文件名、否则返回d1的keys子文件夹名
End Function

• Redim Preserve
• 调用Dos中的Dir命令

Sub ListFilesDos()
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
    If Not myFolder Is Nothing Then myPath$ = myFolder.Items.Item.Path Else MsgBox "Folder not Selected": Exit Sub
    
    myFile$ = InputBox("Filename", "Find File", ".xl")
    '在这里输入需要指定的关键字，可以是文件名的一部分，或指定文件类型如 ".xl"
    tms = Timer
    With CreateObject("Wscript.Shell") 'VBA调用Dos命令
        ar = Split(.exec("cmd /c dir /a-d /b /s " & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf) '所有文档含子文件夹
        '指定Dos中Dir命令的开关然后提取结果 为指定文件夹以及所含子文件夹内的所有文件的含路径全名。
        s = "from " & UBound(ar) & " Files by Search time: " & Format(Timer - tms, " 0.00s") & " in: " & myPath
        '记录Dos中执行Dir命令的耗时
        tms = Timer: ar = Filter(ar, myFile) '然后开始按指定关键词进行筛选。可筛选文件名或文件类型
        Application.StatusBar = Format(Timer - tms, "0.00s") & " Find " & UBound(ar) + IIf(myFile = "", 0, 1) & " Files " & s
        '在Excel状态栏上显示执行结果以及耗时
    End With
    [a:a] = "": If UBound(ar) > -1 Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
    '清空A列，然后输出结果
End Sub

来源：遍历文件夹(含子文件夹)方法