选取文件夹，枚举文件及子文件夹

① 微软Excel VBA 默认选择文件夹的Dialog对话框

Name	Value	Description
msoFileDialogFilePicker	3	File Picker dialog box.
msoFileDialogFolderPicker	4	Folder Picker dialog box.
msoFileDialogOpen	1	Open dialog box.
msoFileDialogSaveAs	2	Save As dialog box.

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

接下来，直接介绍当前流行的、高大上的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

二、仅列出目标文件夹中所有子文件夹名。（不包括目标文件夹中文件、不包括子文件夹中的文件或子文件夹）

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

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

以下代码仅为示例，可以用，但代码粗糙不足以成为实用程序。
但是可以在此基础上修改为各种可能。

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数组，并不断地更新数组大小……这让代码看上去有点烦。

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

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

追加更正：提去文件个数统计

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

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。

求文件名
=RIGHT(RC1,LEN(RC1)-FIND("/",SUBSTITUTE(RC1,"\","/",LEN(RC1)-LEN(SUBSTITUTE(RC1,"\",""))),1))
=RIGHT(RC1,LEN(RC1)-FIND(" / ",SUBSTITUTE(RC1," \ "," / ",LEN(RC1)-LEN(SUBSTITUTE(RC1," \ ",""))),1))