Excel-VBA查找文件并创建文件目录

应用场景

快速对指定文件夹的文件创建目录（提取文件名），如果文件夹中包含子文件夹，则深度提取

知识要点

1：Application.FileDialog(msoFileDialogFolderPicker) 打开选择文件的对话框

2：FileDialog.Show 方法  显示文件对话框并返回一个 Long 类型的值，指示用户按下的是“操作”按钮 (-1) 还是“取消”按钮 (0)

3：vbDirectory 目录或文件夹

4：GetAttr 函数 返回一个 Integer，此为一个文件、目录、或文件夹的属性

5：ReDim Preserve  当改变原有数组最末维的大小时，使用此关键字可以保持数组中原来的数据

6：FileLen 返回一个 Long，代表一个文件的长度，单位是字节。

7：程序的重点在于递归，当getattr函数判断出当前对象是文件夹时，调用程序自身再次进行文件搜索

Dim arr(), i '声明公共变量，供两个过程调用

Sub 提取文件清单()

    Dim fd As Object, pathstr As String

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    '打开选择文件的对话框

    With fd  '如果选择了目录则提取目录的路径，否则退出程序

        If .Show = -1 Then pathstr = .SelectedItems(1) Else Exit Sub

    End With

    If Right(pathstr, 1) <> '\' Then pathstr = pathstr & '\'  '如果路径右边没有'\'则追加一个

    Cells.Clear  '清除所有单元格的数据

    Application.ScreenUpdating = False  '关闭屏幕更新

    i = 0

    Call 查找(pathstr) '执行查找程序

    '如果找到文件，则所有数组的值导入到单元格中，数组中包括所有找到的文件

    If i > 0 Then [a2].Resize(i, 3) = WorksheetFunction.Transpose(arr)

    [a1:c1].EntireColumn.AutoFit '按字符自动调整宽度

    Application.ScreenUpdating = True '恢复屏幕更新

End Sub

Public Sub 查找(ByVal 路径 As String) '查找文件过程

    Dim dirs() As String, dir_count As Long, file_name As String, file_name_2 As String, j

    If Right(路径, 1) <> '\' Then 路径 = 路径 & '\' '如果路径最后一位非'\'则追加一个'\'

    file_name = Dir(路径 & '*.*', vbDirectory) '获取文件目录名称

    Do While Len(file_name) <> 0 '只要文件目录名存在(目录字符长度大于0)就循环下去

        If Left$(file_name, 1) <> '.' Then  '如果左边第一字符不为'.'

            file_name_2 = 路径 & file_name '获取子目录

            If (GetAttr(file_name_2) And vbDirectory) = vbDirectory Then '如果是文件夹

                dir_count = dir_count 1  '计算子目录数量

                ReDim Preserve dirs(1 To dir_count) As String   '重新声明数组的存储控件

                dirs(dir_count) = file_name_2  '将子目录名称写入到数组dirs中

            Else  '如果不是文件夹目录

                i = i 1

                ReDim Preserve arr(1 To 3, 1 To i) '重新声明数组的存储空间

                arr(1, i) = 路径 '将文件路径写入数组

                arr(2, i) = file_name '将文件名写入数组

                arr(3, i) = FileLen(路径 & file_name) / 1024 / 1024 '将文件大小写入数组

            End If

        End If

        file_name = Dir() '查找下一个文件

    Loop

    For j = 1 To dir_count   '遍历数组dirs ，即对子目录进行查找

        查找 dirs(j) '调用自身再执行文件擦在

    Next j

End Sub