VBA学习笔记49_父子转换遍历文件夹

上节学习了如何遍历一个文件夹的文件，那么如果文件夹中还有子文件夹，如何获取某文件夹及其子文件夹下所有文件的路径呢？

根据之前所学，一旦定义了路径，Dir 函数只会在该路径下循环查找文件，而不会进入子文件夹。

回顾一小段代码：

Filename = Dir(mypath, vbDirectory)
Do
    k = k + 1
    Cells(k, 1) = Filename
    Filename = Dir
Loop Until Filename = ""

当文件名为空后，Dir 函数结束运算，不会继续进入子文件夹（如“1月”、“2月”、“3月”、“测试新建文件夹”）查找文件。

那么，如何实现这一功能？

有两种方法：第一种是 FileSearch，但此方法似乎仅在 Excel 2003 版中有效，其他版本会出错，因此略过不记录。第二种是父子转换法，结合 Dir 函数和数组的应用。

---

父子转换法

1. 思路：先找出所有文件夹路径，再找出所有文件夹下的文件路径

1. 设置数组 arr1 存储文件夹路径，数组 arr2 存储所有文件的路径。

提示：定义足够大的数组，考虑 arr2 需输出为一列，确定数组维度。

2. 获取要搜索的文件夹路径（第一个父文件夹），若未设定路径，程序无需运行。

提示：使用 FileDialog 对象选取文件夹路径并返回。

3. 设置循环，获取每个子文件夹路径，并进入子文件夹继续获取，直到所有路径下不再有子文件夹。

提示：使用两层循环：一层循环查找所有父文件夹下的子文件夹；另一层循环记录一个父文件夹下的子文件夹路径，子文件夹可转换为父文件夹。直到没有新子文件夹，循环结束。

4. 获取所有文件夹路径后，循环查找每个文件夹下的文件路径。同样使用两层循环：一层循环文件夹路径，另一层循环查找文件。
5. 最后输出所有文件路径。

2. 图文解说

• 设置数组 arr1 存储文件夹路径，arr2 存储文件路径。一层循环查找所有父文件夹下的子文件夹，循环变量为 i；另一层循环记录一个父文件夹下的子文件夹路径，循环变量为 k。初始值 i=1，k=1。
• 获取要查找的文件夹路径，存入 arr1(i)，i=1。



• 查找 arr1(1) 的子文件夹（有两个子文件夹），逐一填入 arr1，k=k+1，填入 arr1(k+1) 和 arr1(k+2)，即 arr1(2) 和 arr1(3)。



• i=i+1，查找 arr1(2) 的子文件夹（有三个子文件夹），k=k+1，填入 arr1(4)、arr1(5)、arr1(6)。



• 如此循环，获取所有文件夹路径。
• 循环查找 arr1 中文件夹路径下的文件路径，存入 arr2，然后输出。

PS：查找速度比记录速度慢，需用两个变量分别记录。查询到最后，i 必然等于 k，一旦 i 大于 k，表示所有子文件夹已查找完毕，立即停止循环。

3. 代码

Sub 父子转换法()
    Dim arr1(1 To 10000) As String
    Dim f, i, k, F2, f3, x
    Dim arr2(1 To 100000, 1 To 1) As String, q As Integer
    Dim dig
    Set dig = Application.FileDialog(msoFileDialogFolderPicker)
    With dig
        .Title = "请选择需要查找的文件夹"
        '如果未选择文件夹路径则退出程序，选择了则返回文件地址到 arr1(1)
        If .Show = 0 Then
            Exit Sub
        Else
            '如果选择的是驱动盘，如 D:\，则无需在后面加 "\"
            If VBA.Right(.SelectedItems(1), 1) = "\" Then
                arr1(1) = .SelectedItems(1)
            Else
                arr1(1) = .SelectedItems(1) & "\"
            End If
        End If
    End With
    i = 1
    k = 1
    Do While i <= k
        '查找文件或文件夹路径返回到 f
        f = Dir(arr1(i), vbDirectory)
        On Error Resume Next
        'vbDirectory 会找出无扩展名的文件，可能导致遍历时出错，需忽略错误
        Do
            'vbDirectory 返回的值包含文件路径，需判断是否为文件夹（文件路径带 "."，如 ".xls"）
            If InStr(f, ".") = 0 And f <> "" Then
                k = k + 1
                arr1(k) = arr1(i) & f & "\"
            End If
            f = Dir
        Loop Until f = ""
        i = i + 1
    Loop
    '提取各个文件夹的文件
    For x = 1 To k
        If arr1(x) = "" Then Exit For
        '查找所有文件夹下的文件路径，并用循环记入 arr2
        f3 = Dir(arr1(x) & "*.*")
        Do While f3 <> ""
            q = q + 1
            arr2(q, 1) = arr1(x) & f3
            f3 = Dir
        Loop
    Next x
    ActiveSheet.UsedRange = ""
    Range("A1").Resize(q) = arr2
End Sub

4. 实例（改进）

获取路径下所有文件并返回以下相关文件属性。

代码与上述相似，但需使用 FileSystemObject 属性 和 GetFile 方法 返回文件属性。

FileSystemObject 提供对计算机文件系统的访问权限，包含多个对象，如之前学习的 GetOpenFilename、GetSaveAsFilename 和 FileDialog。因对象较多，此处不展开，可参考以下链接：

FileSystemObject 对象

此处使用 GetFile，返回指定路径中文件对应的对象。

语法： 对象.GetFile

FileSystemObject 属性和 GetFile 方法组合示例：

Dim fso As Object, myfile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set myfile = fso.GetFile("C:\")

实例完整代码：

Sub 提取文件信息()
    Dim arr(1 To 10000) As String
    Dim f, i, k, F2, f3, x
    Dim arr1(1 To 100000, 1 To 6) As String, q As Integer  '6 列放置文件夹名称、大小、修改日期等
    Dim fso As Object, myfile As Object
    Dim dig As Object
    Set dig = Application.FileDialog(msoFileDialogFolderPicker)
    With dig
        .Title = "请选择需要查找的文件夹"
        '如果未选择文件夹路径则退出程序，选择了则返回文件地址到 arr(1)
        If .Show = 0 Then
            Exit Sub
        Else
            '如果选择的是驱动盘，如 D:\，则无需在后面加 "\"
            If VBA.Right(.SelectedItems(1), 1) = "\" Then
                arr(1) = .SelectedItems(1)
            Else
                arr(1) = .SelectedItems(1) & "\"
            End If
        End If
    End With
    i = 1
    k = 1
    Do While i <= k
        If arr(i) = "" Then Exit Do
        f = Dir(arr(i), vbDirectory)
        On Error Resume Next
        'vbDirectory 找出无扩展名的文件，可能导致遍历出错，需忽略错误
        Do
            If InStr(f, ".") = 0 And f <> "" Then
                k = k + 1
                arr(k) = arr(i) & f & "\"
            End If
            f = Dir
        Loop Until f = ""
        i = i + 1
    Loop
    '提取各个文件夹的文件
    Set fso = CreateObject("Scripting.FileSystemObject")
    For x = 1 To UBound(arr)
        If arr(x) = "" Then Exit For
        f3 = Dir(arr(x) & "*.*")
        Do While f3 <> ""
            q = q + 1
            arr1(q, 6) = arr(x) & f3               '第六列放文件路径
            Set myfile = fso.GetFile(arr1(q, 6))   '获取文件对象以查询文件属性
            arr1(q, 1) = f3                        '第一列放文件名称
            arr1(q, 2) = myfile.Size & "字节"      '第二列放文件大小，单位为字节
            arr1(q, 3) = myfile.DateCreated        '第三列放文件创建日期
            arr1(q, 4) = myfile.DateLastModified   '第四列放文件最新修改日期
            arr1(q, 5) = myfile.DateLastAccessed   '第五列放文件最近访问日期
            f3 = Dir
        Loop
    Next x
    Range("a2").Resize(1000, 6) = ""  '清空单元格内容
    Range("a2").Resize(q, 6) = arr1   '将 arr1 数组输出到单元格
End Sub

运行结果展示

---

本篇笔记用到了以往学习的知识点，如 FileDialog、文件属性等，忘得差不多了，需反复查笔记和搜索才完成。感谢评论区刘火火同学，修正了无法查找驱动盘和无扩展名文件的问题。