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

VBA笔记 专栏收录该内容
6 篇文章 1 订阅

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

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

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

  • 3
    点赞
  • 0
    评论
  • 23
    收藏
  • 一键三连
    一键三连
  • 扫一扫,分享海报

相关推荐
<div style="white-space: pre-wrap; line-height: 1.75; font-size: 14px;">这个系列课程会深入讲解Python的各种核心技术的原理和实现。这些技术是对我从事多年Python开发和教学经验的总结,以及很多学员和一线开发人员在工作和学习中遇到的各种技术问题的搜集和整理。同时还包含了各大技术论坛和问答社区(如stack overflow)的精彩问题的回答的总结和引申。</div> <p><!--5f39ae17-8c62-4a45-bc43-b32064c9388a:W3siYmxvY2tJZCI6IjQ1MTctMTYwMjQ4NTg4NzU1MCIsImJsb2NrVHlwZSI6InBhcmFncmFwaCIsInN0eWxlcyI6eyJhbGlnbiI6ImxlZnQiLCJpbmRlbnQiOjAsInRleHQtaW5kZW50IjowLCJsaW5lLWhlaWdodCI6MS43NSwiYmFjay1jb2xvciI6IiIsInBhZGRpbmciOiIifSwidHlwZSI6InBhcmFncmFwaCIsInJpY2hUZXh0Ijp7ImRhdGEiOlt7ImNoYXIiOiLov5kifSx7ImNoYXIiOiLkuKoifSx7ImNoYXIiOiLns7sifSx7ImNoYXIiOiLliJcifSx7ImNoYXIiOiLor74ifSx7ImNoYXIiOiLnqIsifSx7ImNoYXIiOiLkvJoifSx7ImNoYXIiOiLmt7EifSx7ImNoYXIiOiLlhaUifSx7ImNoYXIiOiLorrIifSx7ImNoYXIiOiLop6MifSx7ImNoYXIiOiJQIn0seyJjaGFyIjoieSJ9LHsiY2hhciI6InQifSx7ImNoYXIiOiJoIn0seyJjaGFyIjoibyJ9LHsiY2hhciI6Im4ifSx7ImNoYXIiOiLnmoQifSx7ImNoYXIiOiLlkIQifSx7ImNoYXIiOiLnp40ifSx7ImNoYXIiOiLmoLgifSx7ImNoYXIiOiLlv4MifSx7ImNoYXIiOiLmioAifSx7ImNoYXIiOiLmnK8ifSx7ImNoYXIiOiLnmoQifSx7ImNoYXIiOiLljp8ifSx7ImNoYXIiOiLnkIYifSx7ImNoYXIiOiLlkowifSx7ImNoYXIiOiLlrp4ifSx7ImNoYXIiOiLnjrAifSx7ImNoYXIiOiLjgIIifSx7ImNoYXIiOiLov5kifSx7ImNoYXIiOiLkupsifSx7ImNoYXIiOiLmioAifSx7ImNoYXIiOiLmnK8ifSx7ImNoYXIiOiLmmK8ifSx7ImNoYXIiOiLlr7kifSx7ImNoYXIiOiLmiJEifSx7ImNoYXIiOiLku44ifSx7ImNoYXIiOiLkuosifSx7ImNoYXIiOiLlpJoifSx7ImNoYXIiOiLlubQifSx7ImNoYXIiOiJQIn0seyJjaGFyIjoieSJ9LHsiY2hhciI6InQifSx7ImNoYXIiOiJoIn0seyJjaGFyIjoibyJ9LHsiY2hhciI6Im4ifSx7ImNoYXIiOiLlvIAifSx7ImNoYXIiOiLlj5EifSx7ImNoYXIiOiLlkowifSx7ImNoYXIiOiLmlZkifSx7ImNoYXIiOiLlraYifSx7ImNoYXIiOiLnu48ifSx7ImNoYXIiOiLpqowifSx7ImNoYXIiOiLnmoQifSx7ImNoYXIiOiLmgLsifSx7ImNoYXIiOiLnu5MifSx7ImNoYXIiOiLvvIwifSx7ImNoYXIiOiLku6UifSx7ImNoYXIiOiLlj4oifSx7ImNoYXIiOiLlvogifSx7ImNoYXIiOiLlpJoifSx7ImNoYXIiOiLlraYifSx7ImNoYXIiOiLlkZgifSx7ImNoYXIiOiLlnKgifSx7ImNoYXIiOiLlt6UifSx7ImNoYXIiOiLkvZwifSx7ImNoYXIiOiLlkowifSx7ImNoYXIiOiLlraYifSx7ImNoYXIiOiLkuaAifSx7ImNoYXIiOiLkuK0ifSx7ImNoYXIiOiLpgYcifSx7ImNoYXIiOiLliLAifSx7ImNoYXIiOiLnmoQifSx7ImNoYXIiOiLlkIQifSx7ImNoYXIiOiLnp40ifSx7ImNoYXIiOiLmioAifSx7ImNoYXIiOiLmnK8ifSx7ImNoYXIiOiLpl64ifSx7ImNoYXIiOiLpopgifSx7ImNoYXIiOiLnmoQifSx7ImNoYXIiOiLmkJwifSx7ImNoYXIiOiLpm4YifSx7ImNoYXIiOiLlkowifSx7ImNoYXIiOiLmlbQifSx7ImNoYXIiOiLnkIYifSx7ImNoYXIiOiLjgIIifV0sImlzUmljaFRleHQiOnRydWUsImtlZXBMaW5lQnJlYWsiOnRydWV9fSx7ImJsb2NrSWQiOiIxNTk1LTE2MDUwNDkyMjIyMzIiLCJibG9ja1R5cGUiOiJwYXJhZ3JhcGgiLCJzdHlsZXMiOnsiYWxpZ24iOiJsZWZ0IiwiaW5kZW50IjowLCJ0ZXh0LWluZGVudCI6MCwibGluZS1oZWlnaHQiOjEuNzUsImJhY2stY29sb3IiOiIiLCJwYWRkaW5nIjoiIn0sInR5cGUiOiJwYXJhZ3JhcGgiLCJyaWNoVGV4dCI6eyJkYXRhIjpbeyJjaGFyIjoibyJ9LHsiY2hhciI6ImsifSx7ImNoYXIiOiLvvIwifSx7ImNoYXIiOiLmiJEifSx7ImNoYXIiOiLku6wifSx7ImNoYXIiOiLlsLEifSx7ImNoYXIiOiLlhYgifSx7ImNoYXIiOiLku44ifSx7ImNoYXIiOiJQIn0seyJjaGFyIjoieSJ9LHsiY2hhciI6InQifSx7ImNoYXIiOiJoIn0seyJjaGFyIjoibyJ9LHsiY2hhciI6Im4ifSx7ImNoYXIiOiLnlJ8ifSx7ImNoYXIiOiLmiJAifSx7ImNoYXIiOiLlmagifSx7ImNoYXIiOiLmnaUifSx7ImNoYXIiOiLlvIAifSx7ImNoYXIiOiLlp4sifSx7ImNoYXIiOiLov5kifSx7ImNoYXIiOiLkuIAifSx7ImNoYXIiOiLns7sifSx7ImNoYXIiOiLliJcifSx7ImNoYXIiOiLor74ifSx7ImNoYXIiOiLnqIsifSx7ImNoYXIiOiLnmoQifSx7ImNoYXIiOiLlraYifSx7ImNoYXIiOiLkuaAifSx7ImNoYXIiOiLjgIIifV0sImlzUmljaFRleHQiOnRydWUsImtlZXBMaW5lQnJlYWsiOnRydWV9fV0=--></p>
©️2020 CSDN 皮肤主题: 大白 设计师:CSDN官方博客 返回首页
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值