① 经典Dir
② FSO
即 Scripting. File System Object 的【文件系统对象】脚本方法。
一开始可能Dir方法较为普遍，但随着水平的提高，应用FSO方法因为有更多的好处而更为流行。
我会在本帖详细介绍这二种方法、并且是适合初学者的、循序渐进的方法。
以便大家迅速掌握，并消化吸收以后进入自己的知识库。
最后，我还会向大家介绍第三种方法：在VBA中使用Dos的Dir命令的高效遍历子文件夹中所有指定文件的方法。
补充：由于Application.FileSearch方法仅能用于2003版，以后的版本不再能使用此方法，所以就无需介绍了。
首先要介绍，在VBA代码运行以后，调用【目标文件夹】的方法：
① 微软Excel VBA 默认选择文件夹的Dialog对话框
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
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
这两种选择目标文件夹的方法，总的效果应该都不错。
方法-1 默认Dialog对话框左侧栏有桌面、我的文档等快捷方式，也比较符合一般人的使用习惯。
优点是，本层文件夹内的子文件夹全部以大图标方式列出（也可以改为列表）看起来较为轻松。
缺点是，如果有多层子文件夹，需要一层一层地点下去……似乎比较累一点。
与此相对、方法-2 是浏览器形式，点击+号可以展开、点击-号可以折叠。
因此也有很多人特别喜欢这一种的，尤其是有多层子文件夹时很方便。
接下来，直接介绍当前流行的、高大上的FSO方法。
由简到繁地介绍：
一、仅列出目标文件夹中所有文件。（不包括 子文件夹、不包括子文件夹中的文件）
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
本代码只是一个简单的示例，大家理解以后，就可以改编为任何自己希望的操作代码，
实现对指定目标文件夹内所有文件的遍历。
知识介绍：
Set fso = CreateObject("Scripting.FileSystemObject")
建立FSO 即【文件系统对象】的实例。
这以后，即可简单、直接地引用fso的各种属性（有时间可以自己慢慢研究）
For Each f In fso.GetFolder(myPath).Files
'用FSO方法遍历指定文件夹内所有文件
fso.GetFolder(myPath) 是指对于路径myPath，使用FSO对象方法得到其文件夹.GetFolder属性
然后，对于这个指定的目标文件夹，继续返回其所有文件的属性、即.Files
完整的部分为： fso.GetFolder(myPath).Files
然后，对于这个所有文件的集合即 fso.GetFolder(myPath).Files
通过For……Each循环就可以遍历其中每一个文件了。
具体地，For Each f In 中的f变量，即为每一个文件。
循环中，可以使用f的各种属性。 f.Name只是其中的一种属性=文件名。
二、仅列出目标文件夹中所有子文件夹名。（不包括目标文件夹中文件、不包括子文件夹中的文件或子文件夹）
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
和楼上的代码ListFiles相比，差异很小，仅在于：
fso.GetFolder(myPath) .Files
fso.GetFolder(myPath) .SubFolders
即，把目标文件夹fso.GetFolder(myPath)的属性，
有.Files 所有文件、改为 .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
FSO方法到此暂且告一段落（以后我会再贴出较为实用的代码）
接下来，马不停蹄，向大家介绍标准的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
注意使用字典时，对于【子文件】来说因为是以绝对路径为key所以不用担心有重复。（字典本身也可以去重复）
但是，对于文件名来说，必须考虑在不同的文件夹中存在大量的同名文件，
所以不能直接用文件名作为字典key储存，必须使用计数序号j 作为keys，把文件名作为Item项存入字典，
才能避免文件名重复时不被字典错误覆盖。
呵呵。这个是细节，但是很重要。
其实不用字典也可以。但是要使用Redim数组，并不断地更新数组大小……这让代码看上去有点烦。
Sub ListAllDirTest()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
MsgBox Join(ListAllDir(myPath), vbCr) 'GetAllSubFolder's File
MsgBox Join(ListAllDir(myPath, 1), vbCr) 'GetThisFolder's File
MsgBox Join(ListAllDir(myPath, -1), vbCr) 'GetThisFolder's SubFolder
MsgBox Join(ListAllDir(myPath, -2), vbCr) 'GetAllSubFolder
MsgBox Join(ListAllDir(myPath, 1, "tst"), vbCr) 'GetThisFolder's SpecialFile
MsgBox Join(ListAllDir(myPath, , "tst"), vbCr) 'GetAllSubFolder's SpecialFile
End Sub
Function ListAllDir(myPath$, Optional sb& = 0, Optional SpFile$ = "")
Dim i&, j&, k&, myFile$
ReDim fld(0), file(0) '定义可变数组fld存放子文件夹路径、file存放文件名
fld(0) = myPath '子文件夹初始化写入指定目标文件夹路径
On Error Resume Next
Do
myFile = Dir(fld(i), vbDirectory)
Do While myFile <> ""
If myFile <> "." And myFile <> ".." Then
If (GetAttr(fld(i) & myFile) And vbDirectory) = vbDirectory Then
If Err.Number Then Err.Clear Else j = j + 1: ReDim Preserve fld(j): fld(j) = fld(i) & myFile & ""
Else
If SpFile = "" Then
file(k) = myFile: k = k + 1: ReDim Preserve file(k)
Else
If InStr(myFile, SpFile) Then file(k) = myFile: k = k + 1: ReDim Preserve file(k)
End If
End If
End If
myFile = Dir
Loop
If sb Mod 2 Then Exit Do Else i = i + 1
Loop Until i > UBound(fld)
If sb >= 0 Or Len(SpFile) Then ListAllDir = file Else ListAllDir = fld
End Function
最后，介绍使用VBA语句直接调用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
Dos命令不仅简洁，而且高效。
更正：提去文件个数统计
提取文件结果的数组ar是下标 0开始的1维数组，元素个数应该=UBound(ar)+1 【此处修正+1为ar(0)】
但实际未产生筛选时的文件结果数=UBound(ar) 无需+1 【因为Dos提取时Dir最后1个""也在结果之中】
而当指定筛选参数myFile不为空时，即产生实际筛选以后的数组ar中会排除最后的那个"",所以筛选后的统计文件结果数=UBound(ar) + 1
如果没有产生筛选需求，则UBound(ar)是正确的，不需要+1…………因为Dos提取结果中，最后有1个多余的空格……所以不需要+1修正文件数统计结果的。
但是，如果产生了筛选需求，则最后的空格会被筛去，于是实际结果需要更正为 UBound(ar)+1
所以，正确的修改方法应该是：
Application.StatusBar = Format(Timer - tms, "0.00s") & " Find " & UBound(ar) + IIf(myFile = "", 0, 1) & " Files " & s
FSO 递归方法实现各种指定搜寻的完整代码：
Dim jg(), k&, tms# '因为是递归，所以事先指定存放结果的公用变量数组jg以及计数器k和起始时间tms
Sub ListFilesFso()
sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0) '选定返回模式
SpFile$ = InputBox("匹配文件名或文件类型", "Find Files", ".xl") '指定匹配要求，留空则匹配全部
If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*" '如果指定了文件类型则一律转换为大写字母方便比较
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
ReDim jg(65535, 3)
jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
jg(0, 2) = "Folder": jg(0, 3) = "Path"
'定义存放文件名结果的数组jg 、并写入标题
tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile) '调用递归过程检查指定文件夹及其子文件夹
If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
[a1].CurrentRegion = "": [a1].Resize(k + 1, 4) = jg: [a1].CurrentRegion.AutoFilter Field:=1
'输出结果到工作表，并启用筛选模式
End Sub
Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "") '递归检查子文件夹的过程代码
Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
On Error Resume Next
If sb >= 0 Or Len(SpFile) Then '如果模式为0或1、或指定了匹配文件要求，则遍历各个文件
For Each f In fld.Files '用FSO方法遍历文件.Files
t = False '匹配状态初始化
n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
If Err.Number Then Err.Clear
If SpFile = " " Then 'Space 如果匹配要求为空则匹配全部
t = True
ElseIf SpFile Like ".*" Then '如果匹配要求为文件类型则
If x Like SpFile Then t = True '当文件符合文件类型要求时匹配，否则不匹配
Else '否则为需要匹配文件名称中的一部分
If InStr(fnm, SpFile) Then t = True '如果匹配则状态为True
End If
If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = fld.Path
Next
Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
End If
For Each fd In fld.SubFolders '然后遍历检查所有子文件夹.SubFolders
If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = fld.Path
If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
Next
End Function
附录：
关于Dos中Dir命令的开关问题：
【提取文档】
.Exec("cmd /c dir /a-d /b " ………Dir返回指定文件夹下【不包括子文件夹】的所有文档名（不含文件夹）
.Exec("cmd /c dir /a-d /b /s " ………Dir返回指定文件夹下【包括子文件夹】在内的所有文档名（不含文件夹）
其中， /s 即 是否包含 SubFolder的意思
而 /a-d 是文件对象中排除文件夹目录(-d)只剩下文档的意思。
【提取文件夹】
.Exec("cmd /c dir /a-a /b " ………Dir返回指定文件夹下【不包括子文件夹】内的所有子文件夹名（不含文档）
.Exec("cmd /c dir /a-a /b /s " ………Dir返回指定文件夹下【包括子文件夹】内的所有子文件夹名（不含文档）
而 /a-a 是文件对象中排除文档(-a)只剩下文件夹目录的意思。
【提取文档和文件夹】
.Exec("cmd /c dir /b " ………Dir返回指定文件夹下【不包括子文件夹】的所有【文档名】和【文件夹名】
.Exec("cmd /c dir /b /s " ………Dir返回指定文件夹下【包括子文件夹】的所有【文档名】和【文件夹名】
呵呵，以上6种的开关组合就足够了。
补充：Dos Dir开关的帮助文件：
显示目录中的文件和子目录列表。
DIR [drive:][path][filename] [/A[[:]attributes]] [/B] [/C] [/D] [/L] [/N]
[/O[[:]sortorder]] [/P] [/Q] [/S] [/T[[:]timefield]] [/W] [/X] [/4]
[drive:][path][filename]
指定要列出的驱动器、目录和/或文件。
/A 显示具有指定属性的文件。
attributes D 目录 R 只读文件
H 隐藏文件 A 准备存档的文件
S 系统文件 - 表示“否”的前缀
/B 使用空格式(没有标题信息或摘要)。
/C 在文件大小中显示千位数分隔符。这是默认值。用 /-C 来
停用分隔符显示。
/D 跟宽式相同，但文件是按栏分类列出的。
/L 用小写。
/N 新的长列表格式，其中文件名在最右边。
/O 用分类顺序列出文件。
sortorder N 按名称(字母顺序) S 按大小(从小到大)
E 按扩展名(字母顺序) D 按日期/时间(从先到后)
G 组目录优先 - 颠倒顺序的前缀
/P 在每个信息屏幕后暂停。
/Q 显示文件所有者。
/S 显示指定目录和所有子目录中的文件。
/T 控制显示或用来分类的时间字符域。
timefield C 创建时间
A 上次访问时间
W 上次写入的时间
/W 用宽列表格式。
/X 显示为非 8dot3 文件名产生的短名称。格式是 /N 的格式，
短名称插在长名称前面。如果没有短名称，在其位置则
显示空白。
/4 用四位数字显示年
可以在 DIRCMD 环境变量中预先设定开关。通过添加前缀 - (破折号)
来替代预先设定的开关。例如，/-W。
FSO递归代码也很简单：
Function ListAllFso(myPath$)
Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
For Each f In fld.Files
[a65536].End(3).Offset(1) = f.Name
Next
For Each fd In fld.SubFolders
[a65536].End(3).Offset(1) = " " & fd.Name & ""
Call ListAllFso(fd.path)
Next
End Function
前面的Dir代码，是两个Do循环嵌套使用，
一边检查当前文件夹内的子文件夹，一边检查当前文件夹内的文件。
其实，Dir方法也可以这么写代码：
① 检查并列出所有子文件夹
② 然后根据需要遍历所有子文件夹中的文件
即，两个Do循环是分开来的。
但是、第2次的Do循环需要外套For循环遍历所有已知子文件夹。
Sub ListFilesDir()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
MsgBox Join(ListAllDir(myPath), vbCr) 'GetAllSubFolder's File
MsgBox Join(ListAllDir(myPath, 1), vbCr) 'GetThisFolder's File
MsgBox Join(ListAllDir(myPath, -1), vbCr) 'GetThisFolder's SubFolder
MsgBox Join(ListAllDir(myPath, -2), vbCr) 'GetAllSubFolder
MsgBox Join(ListAllDir(myPath, , "tst"), vbCr) 'GetAllSubFolder's SpecialFile
MsgBox Join(ListAllDir(myPath, 1, "tst"), vbCr) 'GetThisFolder's SpecialFile
End Sub
Function ListAllDir(myPath$, Optional sb& = 0, Optional SpFile$ = "")
Dim i&, j&, k&, myFile$
ReDim fld(0)
fld(0) = myPath
On Error Resume Next
Do
myFile = Dir(fld(i), vbDirectory)
Do While myFile <> ""
If myFile <> "." And myFile <> ".." Then
If (GetAttr(fld(i) & myFile) And vbDirectory) = vbDirectory Then
If Err.Number Then Err.Clear Else j = j + 1: ReDim Preserve fld(j): fld(j) = fld(i) & myFile & ""
End If
End If
myFile = Dir
Loop
If sb Mod 2 Then Exit Do Else i = i + 1
Loop Until i > UBound(fld)
If sb < 0 And Len(SpFile) = 0 Then ListAllDir = fld: Exit Function
'以上为止，遍历检查并列出指定目标文件夹中、所有的子文件夹。
'以下为遍历已获得的子文件夹数组fld 然后Dir循环检查其中所有的文件
ReDim file(0)
For i = 0 To UBound(fld)
myFile = Dir(fld(i), vbDirectory)
Do While myFile <> ""
If myFile <> "." And myFile <> ".." Then
If Not (GetAttr(fld(i) & myFile) And vbDirectory) = vbDirectory Then
If SpFile = "" Then
file(k) = myFile: k = k + 1: ReDim Preserve file(k)
Else
If InStr(myFile, SpFile) Then file(k) = myFile: k = k + 1: ReDim Preserve file(k)
End If
End If
End If
myFile = Dir
Loop
Next
ListAllDir = file
End Function
一般说，还是第1种两个Do嵌套的方法好……虽然代码中需要同时处理文件夹和文件名，但Do循环比较高效一些。
第2种方法也并非全无是处。
当处理文件为重点时，以第2种方法比较好。
补充：
myPath$ = myFolder.Items.Item.Path
上句中"$"是什么意思？ 是定义为dim myPath as String的意思吗？
答：
①
myPath$ = "PathStr"
②
Dim myPath$
myPath = "PathStr"
③
Dim myPath As String
myPath = "PathStr"
这3种写法的实质是一样的。
补充，下面做法不可以：myPath$ = "PathStr"
Dim myPath$ 因为前面已经定义并使用了变量myPath，所以后面的Dim会产生冲突。
但是，
Dim myPath$
myPath$ = "PathStr"
这样第2次重复规定变量类型倒是不会产生错误。……除非你前后两次规定的数据类型不一致才会发生错误。
关于变量类型缩写的快速记忆：
! = Single 单精度小数……因为 ! 笔画只是1竖单笔画，所以记住为【单精度】
# = Double 双精度小数 …因为 # 笔画是2横2竖，所以记住为【双精度】
@ = Currency 货币型4位小数 …现实中大家也常用@符号代表价格、单价，所以记住为【货币型小数】
$ = String 文本字符串 …因为 String第1个字母是 S 所以记住为【美元s=String 文本字符串】
% = Integer 整数 ……因为 % 是百分比符号我们把它联想为较少的整数【整型数值】
& = Long 整数 ……因为 & 可以看做是Long首字母L的花体字 所以记住为【长整型数值】
呵呵，这样稍稍动脑筋记忆一下，以后就可以简单使用了。
比如这样子：
Dim i&, j&, k&, l&, l1&, l2&, m&, n&, s$, w1$, w2$
但是，新手千万不要这样子：
Dim i, j, k, l, l1, l2, m, n As Long
Dim s, w1,w2 As String
这样做，只有最后一个蓝色的变量被正确定义了变量类型，
其它的都会被作为Variant变量使用……或许不影响使用，但至少违背了作者的初衷。所以不好。
【Dir 使用方法】
myPath = "c:\" '首先设定目标文件夹，注意末尾必须是【\】文件夹符号。
myFile = Dir(myPath, vbDirectory) '第一次使用Dir函数时，必须完整输入路径和检索要求。
' 如果直接使用Dir不带参数则会报错。
Do While myFile <> "" '开始Do不定循环、直至在本文件夹内没有找到文档/文件夹而返回空白时停止。
If myFile <> "." And myFile <> ".." Then
'此If判断为忽略 当前文件夹"."以及忽略上级文件夹".."
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
'接下来的If判断是：通过二进制的位比较计算结果= vbDirectory 来判断这是一个文件夹。
Debug.Print myFile '判断为文件夹时的处理
Else '否则为文档
Debug.Print myFile '判断为文档时的处理。
End If
End If
myFile = Dir '继续调用【不带路径参数的Dir函数】 这样就能得到下一个搜寻结果。
Loop
补一个方法
如何列出文件夹及其所有子文件夹中的文件？
问：
您好，脚本专家！如何列出某个文件夹中的所有文件以及该文件夹的所有子文件夹中的所有文件？
-- MA
答：
您好，MA。有很多用户提出过这个问题，我们还没来得及作出解答。这是因为，这个问题还没有一个既有效又简便的解决办法：能够完成这一任务的脚本注定会有些不易理解，也无法通过本专栏惯用的简洁明了的方式进行解决。从另一方面来说，客户永远是正确的：如果您们需要一个能够列出某个文件夹中的所有文件以及该文件夹的所有子文件夹中的所有文件的脚本，我们还有什么可说的呢？
着手编写脚本前，必须先解决两个问题。第一，需要选择一种脚本技术。WMI、FileSystemObject 及 Shell 对象都能列出文件夹中的文件以及文件夹中的子文件夹。不过，这些技术都没有能够自动列出这些子文件夹中文件的机制（更不必说可能存在的再下一级文件夹了）。使用上述任何一种技术都可以达到目的，但都不是非常容易。
我们倾向于使用 WMI。使用它编写的脚本可能比使用 FileSystemObject 或 Shell 对象编写的类似脚本复杂一些，但 WMI 脚本的优点是，在本地计算机上检索此类信息与从远程计算机中检索同样方便。而 FileSystemObject 或 Shell 对象都做不到这一点。我们看重的是 WMI 的灵活性。
第二，我们注意到，所有这些脚本技术都没有完成以下操作的内置方法：循环访问文件夹，列出文件名，然后自动循环访问所有子文件夹并列出其中的文件。因此，需要使用"递归函数"来执行这项任务。对递归进行说明超出了本专栏的讨论范围；有关简要说明，请参阅 Microsoft Windows 2000 脚本编写指南。只需说我们要创建一个可以根据需要多次调用自身的函数就够了。换句话说，如果我们有可以访问某个文件夹并列出其中所有文件的函数，则该函数可以调用自身来访问子文件夹并列出其中的所有文件，然后再次调用自身来访问再下一级文件夹。很难以直观的方式来说明这一点，但这种方法的确奏效。
它还会产生一个新问题，我们稍后再进行讨论。我们先来看一个脚本，它的作用是列出某个文件夹及其所有子文件夹（但这第一个示例脚本并未列出这些文件夹中的任何文件）：
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
strFolderName = "c:\scripts"
Set colSubfolders = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
For Each objFolder in colSubfolders
GetSubFolders strFolderName
Next
Sub GetSubFolders(strFolderName)
Set colSubfolders2 = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
For Each objFolder2 in colSubfolders2
strFolderName = objFolder2.Name
Wscript.Echo objFolder2.Name
GetSubFolders strFolderName
Next
End Sub
'---------------------------------------------------------------------------
以上脚本的作用是使用"AssociatorsOf"查询来获取文件夹 C:\Scripts 的所有子文件夹的列表。我们的查询所要表达的基本意思是：给我提供与目录 C:\Scripts 相关的所有项目的列表，但前提是这些项目是子目录（"Where AssocClass = Win32_Subdirectory"）。
此脚本获取的是所有*子文件夹的列表：例如，C:\Scripts\Folder1 和 C:\Scripts\Folder2。它不能获取任何下一级文件夹；此查询无法返回像 C:\Scripts\Folder1\SubfolderA 之类的文件夹。要获取这些下一级子文件夹（子文件夹的子文件夹），我们需要使用递归查询。子例程"GetSubFolders"可以实现这个目的。我们将找到的每个子文件夹的名称（如 C:\Scripts\Folder1 和 C:\Scripts\Folder2）逐一传递给该子例程，使之查询这些子文件夹中是否有下一级子文件夹。如果有任何下一级子文件夹，该函数将自动调用自身并查找是否有再下一级子文件夹。
感到困惑不解吗？不必沮丧；很多人都会有这种感觉。但不要担心，只需让代码保持原样并运行即可。要搜索其他文件夹（即 C:\Scripts 以外的文件夹），只需更改包含要搜索的文件夹的变量值即可。例如，如果要搜索 C:\Windows，请使用以下这行代码：
strFolderName = "c:\windows"
那么，如何列出所有这些文件夹中的文件？从现在开始，情况确实变得更复杂了。这是因为，我们需要再执行一个查询：我们使用一个查询来获取所有子文件夹的名称，然后使用另一个查询获取每个文件夹中的文件集合。这第二个查询恰好与以下内容非常相似：
Set colFiles = objWMIService.ExecQuery _
("Select * from CIM_DataFile where Path = '" & strPath & "'")
这还不算太复杂，但以下情况就不同了：在此类查询中，必须"转义"在文件路径中出现的 \（使用两个 \\）。不能在查询中使用"C:\Scripts\Folder1\"；而必须使用"C:\\Scripts\\Folder1\\"。您会发现，脚本中的代码将每个 \ 都替换为 \\；在此类查询中引用文件路径时，这正是我们需要做的。脚本中相当大一部分内容专用于转换文件夹路径名，以使它们可以在查询中使用。
注意事项就讲这么多。以下便是每位用户都想一睹为快的脚本：
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
strFolderName = "c:\scripts"
Set colSubfolders = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
Wscript.Echo strFolderName
arrFolderPath = Split(strFolderName, "\")
strNewPath = ""
For i = 1 to Ubound(arrFolderPath)
strNewPath = strNewPath & "\\" & arrFolderPath(i)
Next
strPath = strNewPath & "\\"
Set colFiles = objWMIService.ExecQuery _
("Select * from CIM_DataFile where Path = '" & strPath & "'")
For Each objFile in colFiles
Wscript.Echo objFile.Name
Next
For Each objFolder in colSubfolders
GetSubFolders strFolderName
Next
Sub GetSubFolders(strFolderName)
Set colSubfolders2 = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
For Each objFolder2 in colSubfolders2
strFolderName = objFolder2.Name
Wscript.Echo
Wscript.Echo objFolder2.Name
arrFolderPath = Split(strFolderName, "\")
strNewPath = ""
For i = 1 to Ubound(arrFolderPath)
strNewPath = strNewPath & "\\" & arrFolderPath(i)
Next
strPath = strNewPath & "\\"
Set colFiles = objWMIService.ExecQuery _
("Select * from CIM_DataFile where Path = '" & strPath & "'")
For Each objFile in colFiles
Wscript.Echo objFile.Name
Next
GetSubFolders strFolderName
Next
End Sub
'---------------------------------------------------------------------------
我们曾说过脚本比较复杂。不过还真管用！此脚本所执行的操作如下：绑定到 C:\Scripts 文件夹并回显其中的所有文件的名称，然后获取 C:\Scripts 中所有子文件夹的列表。接着循环访问子文件夹集合，并为每个子文件夹调用递归函数 GetSubFolders。该函数将列出子文件夹中的所有文件，然后检查该子文件夹是否有下一级子文件夹。如果有，将再次调用递归函数；继续重复执行这一过程，直至无法再继续为止，即列出了 C:\Scripts 及其所有子文件夹中的所有文件。
把Wscript.Echo
替换为 Msgbox 即可
代码另存为 ***.vbs 即可
此方法整理：
使用WMI方法，需要：
要使用WMI要满足以下条件：
1、VBE中添加对“Microsoft WMI Scripting V1.2 Library”的引用。
2、Windows里的WMI 服务（winmgmt）保证是运行的。
即在VBA代码中要有：
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
arrFolderPath = Split(strFolderName, "\")
strNewPath = ""
For i = 1 to Ubound(arrFolderPath)
strNewPath = strNewPath & "\\" & arrFolderPath(i)
Next
strPath = strNewPath & "\\"
这么6句代码，我只要一句就能实现了：
strPath = Mid(Replace(strFolderName, "\", "\\") & "\\", 3)
故贴出完整代码：
Sub ListFilesWMI()
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
[a:a] = "": [a1] = "Folder: " & myPath
tms = Timer: Call GetSubFolders(myPath)
MsgBox Format(Timer - tms, "0.000s")
End Sub
Sub GetSubFolders(strFolderName)
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
strPath = Mid(Replace(strFolderName, "", "\") & "\", 3)
Set colFiles = objWMIService.ExecQuery _
("Select * from CIM_DataFile where Path = '" & strPath & "'")
For Each objFile In colFiles
[a65536].End(3).Offset(1) = " Files: " & objFile.Name
Next
Set colSubfolders = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")
For Each objFolder In colSubfolders
[a65536].End(3).Offset(1) = "Folder: " & objFolder.Name
Call GetSubFolders(objFolder.Name)
Next
End Sub
解释1：输出Dos中Dir各种开关参数的帮助文件：
Sub ListDosDirHelp()
With CreateObject("Wscript.Shell") 'VBA调用Dos命令
ar = Split(.exec("cmd /c dir /?").StdOut.ReadAll, vbCrLf)
'Dos中Dir命令的开关设置为"/?" 即返回各种开关的帮助文件信息。
End With
[a1].Resize(UBound(ar)) = WorksheetFunction.Transpose(ar)
End Sub
解释2 ：Dos版 加入Dir各种参数以后的完整代码
Sub ListFilesDos()
myMode& = Val(InputBox("Search Mode:-3 To 3", "Find File", 0)) '指定Dos Dir的查找开关、返回模式
'奇数为不含子文件夹、偶数为含子文件夹 / 负数为目录、正数为文档 / >1为文档及目录
If myMode > -3 Then
myFile$ = InputBox("Part of Filename or Filetype as "".xl""", "Find File", ".xl")
'输入指定关键字，可以是文件(文档和目录)名称中的任意部分，或指定文件类型如 ".xl"
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
'浏览列表指定查找目录
End If
tms = Timer
With CreateObject("Wscript.Shell") 'VBA调用Dos命令
cmdStr = Choose(myMode + 4, "/? ", "/a:d /b /s ", "/a:d /b ", "/a:a /b /s ", "/a:a /b ", "/b /s ", "/b ", "/a:a /o:e /o:n /s ", "/a:a /o:e /o:n ", "/a:d /o:e /o:n /s ", "/a:d /o:e /o:n ")
ar = Split(.exec("cmd /c dir " & cmdStr & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf)
'指定Dos中Dir命令的开关然后提取结果 为指定文件夹以及所含子文件夹内的所有文件的含路径全名。
s = UBound(ar) & " Files by Search time: " & Format(Timer - tms, " 0.00s") & " in: " & myPath
Application.StatusBar = " Find " & s: tms = Timer '记录Dos中执行Dir命令的耗时 并在Excel状态栏上显示
If myFile <> "" Then '如指定了匹配关键字则
ar = Filter(ar, myFile) '按指定关键词myFile进行筛选。可筛选文件名或文件类型、然后在Excel状态栏上显示结果
Application.StatusBar = Format(Timer - tms, "0.00s") & " Find " & 1 + UBound(ar) & " Files from " & s
End If
End With
[a:a] = "": If UBound(ar) > -1 Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
' 清空A列，然后输出结果
End Sub
为大家看得清楚明白，把各种开关写成Select形式：
Select Case myMode '根据开关模式设置Dos Dir的开关参数
Case -3
cmdStr = "cmd /c dir /?" '列出Dir各个参数开关的帮助文件
Case -2
cmdStr = "cmd /c dir /a-a /b /s " & Chr(34) & myPath & Chr(34) '目录不含文档[/a-a]含子文件夹
Case -1
cmdStr = "cmd /c dir /a-a /b " & Chr(34) & myPath & Chr(34) '目录不含文档[/a-a](不含子文件夹)
Case 0
cmdStr = "cmd /c dir /a-d /b /s " & Chr(34) & myPath & Chr(34) '文档不含目录[/a-d]含子文件夹
Case 1
cmdStr = "cmd /c dir /a-d /b " & Chr(34) & myPath & Chr(34) '文档不含目录[/a-d](不含子文件夹)
Case 2
cmdStr = "cmd /c dir /b /s " & Chr(34) & myPath & Chr(34) '所有文档及目录含子文件夹
Case 3
cmdStr = "cmd /c dir /a-d /b " & Chr(34) & myPath & Chr(34) '所有文档及目录(不含子文件夹)
End Select
但实际代码中用Choose语句简化。
解释3：选择磁盘根目录时会出现下面的错误，什么原因？
大部分的遍历文件夹的代码都会有这个缺陷：当文件夹权限不足，或者文件夹和文件损坏的时候，代码就会报错
另：
当递归返回的条件是不存在子目录则返回（不返回自然成了死递归）集合fld.Subfolders为空，那么集合遍历循环for each 因为找不到对象不循环，因此不会再度进行递归调用从而执行End Function 弹出栈，这里写的很巧妙~！
解释4：整理了调用cmd的代码附上
Enum aSearchType
aSearchTypeFolder = 0
aSearchTypeFile = 1
aSearchTypeAll = 2
End Enum
Function mySearch(aPath$, Optional searchTraversal As Boolean = True, Optional searchType As aSearchType = aSearchTypeFile) As String()
'参数1：遍历目录全路径
'参数2：是否搜索子目录
'参数3：搜索文件、目录或者全部
Dim aNum&, cmdStr$, folder$, aTemp$
folder = """" & aPath & """"
cmdStr = Environ$("comspec") & " /c dir " & folder '初始化字串
If searchTraversal Then cmdStr = cmdStr & " /s" '定义是否遍历
aTemp = Mid(aPath, InStrRev(aPath, "") + 1) '获取最后一个""后的内容
If Left(aTemp, 2) = "*." Then searchType = aSearchTypeFile
If searchType = aSearchTypeFile Then '定义搜索文件、目录还是全部
cmdStr = cmdStr & " /a:-d /b"
ElseIf searchType = aSearchTypeFolder Then
cmdStr = cmdStr & " /a:d /b"
ElseIf searchType = aSearchTypeAll Then
cmdStr = cmdStr & " /b"
End If
cmdStr = cmdStr & " > C:\aTemp.txt"
With CreateObject("WScript.Shell")
.Run cmdStr, 0, True
End With
aNum = FreeFile
Open "C:\aTemp.txt" For Input As #aNum
mySearch = Split(StrConv(InputB(LOF(aNum), aNum), vbUnicode), vbCrLf)
Close #aNum
End Function