跟我学 【喜迎2015立春】遍历文件夹(含子文件夹)方法 ABC

香川群子

接下来，马不停蹄，向大家介绍标准的Dir搜寻文件、子文件夹的方法。

1. Sub ListAllDirDicTest()
   
2.     With Application.FileDialog(msoFileDialogFolderPicker)
   
3.         If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
   
4.     End With
   
5.     If Right(myPath, 1) <> "" Then myPath = myPath & ""
   
6.    
   
7.     MsgBox Join(ListAllDirDic(myPath), vbCr) 'GetAllSubFolder's File 列出目标文件夹内含子文件夹内所有文件
   
8.     MsgBox Join(ListAllDirDic(myPath, 1), vbCr) 'GetThisFolder's File 列出目标文件夹内所有文件(不含子文件夹)
   
9.    
   
10.     MsgBox Join(ListAllDirDic(myPath, -1), vbCr) 'GetThisFolder's SubFolder 仅列出目标文件夹内的子文件夹
    
11.     MsgBox Join(ListAllDirDic(myPath, -2), vbCr) 'GetAllSubFolder 列出目标文件夹内含子文件夹的所有子文件夹
    
12.    
    
13.     MsgBox Join(ListAllDirDic(myPath, 1, "tst"), vbCr) 'GetThisFolder's SpecialFile 仅列出文件夹内含关键字文件
    
14.     MsgBox Join(ListAllDirDic(myPath, , "tst"), vbCr) 'GetAllSubFolder's SpecialFile 列出子文件夹内含关键字文件
    
15.    
    
16. End Sub
    
17. 
    
18. Function ListAllDirDic(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    
19.     '利用Dir方法、以及用2个字典分别记录子文件夹路径和文件名的文件搜寻方法。
    
20. 
    
21.     '第1参数【指定路径myPath】必选 为指定目标文件夹的绝对路径
    
22. 
    
23.     '第2参数【子文件夹模式sb】为可选 =奇数时只搜寻当前文件夹、=偶数时搜寻所有子文件夹
    
24.     '                                      该参数>=0时返回文件名、<0时返回文件夹路径名
    
25.     '因此事实上第2参数可以设置这样四种模式：
    
26.     '  默认=0时，搜寻所有子文件夹并返回所有文件名
    
27.     '        =1时，搜寻当前文件夹并返回所有文件名 (不向下搜寻子文件夹)
    
28.     '        =-1时，搜寻当前文件夹并返回子文件夹路径名
    
29.     '        =-2时， 搜寻所有子文件夹并返回所有子文件夹路径名
    
30. 
    
31.     '第3参数【文件名指定特殊匹配字符SpFile】 可选，返回文件名时用此关键词过滤一下
    
32.     '默认留空时，返回全部文件名 （等于没有被过滤掉）
    
33.     ' = 某个关键字时，返回符合匹配（即含该关键字）的部分文件名 （有过滤掉不含关键字的文件名）
    
34.     ' = .xl 也可这样指定文件类型，返回匹配（该关键字指定文件类型）的部分文件名 （过滤掉其它类型文件名）
    
35.    
    
36.     Dim i&, j&, myFile$
    
37.     Set d1 = CreateObject("Scripting.Dictionary") '定义存放子文件夹路径的字典d1
    
38.     Set d2 = CreateObject("Scripting.Dictionary") '定义存放文件名的字典d2
    
39.    
    
40.     d1(myPath) = " '字典d1初始化记录目标文件夹路径名
    
41.     On Error Resume Next
    
42.     Do While i < d1.Count
    
43.         kr = d1.Keys  '从字典d1中更新提取所有子文件夹
    
44.         myFile = Dir(kr(i), vbDirectory) '用Dir方法遍历该子文件夹得到文件或文件夹名 注意从kr(i)开始避免重复
    
45.         Do While myFile <> "" 'Dir遍历直到返回空字符串 （即无未被遍历的文件或文件夹了）
    
46.             If myFile <> "." And myFile <> ".." Then '如果是"."或".."属性则不用处理
    
47.                 If (GetAttr(kr(i) & myFile) And vbDirectory) = vbDirectory Then '判断是文件夹属性时
    
48.                     If Err.Number Then Err.Clear Else d1(kr(i) & myFile & "") = ""
    
49.                     '#52 文件名Err时忽略（一般为操作系统语言文字环境问题），否则字典d1记录该子文件夹路径
    
50.                 Else '如果不是文件夹则为文件
    
51.                     If SpFile = "" Then '如未指定关键字
    
52.                         j = j +1: d2(j) = myFile '则所有文件名都作为Item项加入字典d2 (不能使用key防止重名文件)
    
53.                     Else '否则指定了关键字
    
54.                         If InStr(myFile, SpFile) Then j = j +1: d2(j) = myFile
    
55.                         '则判断含有指定关键字以后才可作为Item项加入字典d2 (不能使用key防止重名文件)
    
56.                     End If
    
57.                 End If
    
58.             End If
    
59.             myFile = Dir '用Dir方法继续搜寻下一个文件或子文件夹
    
60.         Loop
    
61.         If sb Mod 2 Then Exit Do Else i = i + 1
    
62.         '如果第2参数指定为奇数则不用继续检查子文件夹就可退出，
    
63.         '否则 i+1避免重复检查然后利用字典d1中的记录，继续检查下一个子文件夹直到全部子文件夹检查完毕
    
64.     Loop
    
65.     If sb >= 0 Or Len(SpFile) Then ListAllDirDic = d2.Items Else ListAllDirDic = d1.Keys
    
66.     '如果第2参数>=0或第3参数有指定则返回d2的Items文件名、否则返回d1的keys子文件夹名
    
67. End Function

复制代码

呵呵。

zongyj

收藏，学习！！

sunny_8848

收藏学习，谢谢精彩分享

香川群子

其实不用字典也可以。但是要使用Redim数组，并不断地更新数组大小……这让代码看上去有点烦。

解释暂略（因为很上面一样的）

1. Sub ListAllDirTest()
   
2.     With Application.FileDialog(msoFileDialogFolderPicker)
   
3.         If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
   
4.     End With
   
5.     If Right(myPath, 1) <> "" Then myPath = myPath & ""
   
6.    
   
7.     MsgBox Join(ListAllDir(myPath), vbCr) 'GetAllSubFolder's File
   
8.     MsgBox Join(ListAllDir(myPath, 1), vbCr) 'GetThisFolder's File
   
9.    
   
10.     MsgBox Join(ListAllDir(myPath, -1), vbCr) 'GetThisFolder's SubFolder
    
11.     MsgBox Join(ListAllDir(myPath, -2), vbCr) 'GetAllSubFolder
    
12.    
    
13.     MsgBox Join(ListAllDir(myPath, 1, "tst"), vbCr) 'GetThisFolder's SpecialFile
    
14.     MsgBox Join(ListAllDir(myPath, , "tst"), vbCr) 'GetAllSubFolder's SpecialFile
    
15.    
    
16. End Sub
    
17. 
    
18. Function ListAllDir(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    
19.     Dim i&, j&, k&, myFile$
    
20.     ReDim fld(0), file(0) '定义可变数组fld存放子文件夹路径、file存放文件名
    
21.    
    
22.     fld(0) = myPath '子文件夹初始化写入指定目标文件夹路径
    
23.     On Error Resume Next
    
24.     Do
    
25.         myFile = Dir(fld(i), vbDirectory)
    
26.         Do While myFile <> ""
    
27.             If myFile <> "." And myFile <> ".." Then
    
28.                 If (GetAttr(fld(i) & myFile) And vbDirectory) = vbDirectory Then
    
29.                     If Err.Number Then Err.Clear Else j = j + 1: ReDim Preserve fld(j): fld(j) = fld(i) & myFile & ""
    
30.                 Else
    
31.                     If SpFile = "" Then
    
32.                         file(k) = myFile: k = k + 1: ReDim Preserve file(k)
    
33.                     Else
    
34.                         If InStr(myFile, SpFile) Then file(k) = myFile: k = k + 1: ReDim Preserve file(k)
    
35.                     End If
    
36.                 End If
    
37.             End If
    
38.             myFile = Dir
    
39.         Loop
    
40.         If sb Mod 2 Then Exit Do Else i = i + 1
    
41.     Loop Until i > UBound(fld)
    
42.     If sb >= 0 Or Len(SpFile) Then ListAllDir = file Else ListAllDir = fld
    
43. End Function
    

复制代码

jjj2123456?

香川群子 发表于 2015-2-4 12:16
其实不用字典也可以。但是要使用Redim数组，并不断地更新数组大小……这让代码看上去有点烦。

解释暂略（ ...

老师的代码太高深了，慢慢学习。

香川群子

注意使用字典时，对于【子文件】来说因为是以绝对路径为key所以不用担心有重复。（字典本身也可以去重复）

但是，对于文件名来说，必须考虑在不同的文件夹中存在大量的同名文件，
所以不能直接用文件名作为字典key储存，必须使用计数序号j 作为keys，把文件名作为Item项存入字典，
才能避免文件名重复时不被字典错误覆盖。

呵呵。这个是细节，但是很重要。

lhsh36183

收藏学习，谢谢精彩分享

feiren228

香川群子 发表于 2015-2-4 12:42
注意使用字典时，对于【子文件】来说因为是以绝对路径为key所以不用担心有重复。（字典本身也可以去重复）
...

这点要注意，谢谢提醒！

香川群子

最后，作为本帖的特色，介绍使用VBA语句直接调用Dos中Dir命令来搜寻文件名的方法：

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

复制代码

呵呵，Dos命令不仅简洁，而且高效。

追加更正：提去文件个数统计
提取文件结果的数组ar是下标 0开始的1维数组，元素个数应该=UBound(ar)+1 【此处修正+1为ar(0)】
但实际未产生筛选时的文件结果数=UBound(ar) 无需+1 【因为Dos提取时Dir最后1个""也在结果之中】
而当指定筛选参数myFile不为空时，即产生实际筛选以后的数组ar中会排除最后的那个"",所以筛选后的统计文件结果数=UBound(ar) + 1

zhouzhongchi

这个好！
致敬！