实用VBA：6.一键批量提取文件名和存储路径

1.需求范例

工作中经常会遇到需要对大量文件进行检查、整理、筛选、处理的情况。所有操作的前提是先梳理出有多少文件需要处理，文件存储在什么位置，如果文件目录结构比较复杂，手工逐一打开文件夹进行人工检查是繁琐、低效而不可靠的。如果能够将文件存储路径和文件名提取到excel表格中，就可以直观地观察到文件存储的结构特点。

例如我需要将下面文件夹中的文件信息提取出来，进行后续的归类、检查。

2.基本思路

（1）定义一个文件系统对象，提取出存储路径和文件名信息。

（2）对子目录进行递归提取。

3.VBA实现

Dim wb As Workbook          '定义工作簿（文件）变量

Dim ws As Worksheet         '定义工作表变量

'定义函数，获取文件系统对象的路径和文件名信息，填入表格

'参数 pth 表示想要获取的文件和文件夹所在的根目录

Public Function get_folder_file(pth)

    '设置文件系统对象变量

    Set fso = CreateObject("Scripting.FileSystemObject").GetFolder(pth)

    '第一部分，遍历当前目录下所有文件对象，获取其存储路径和文件名

    For Each file In fso.Files

        '单元格行号变量，游标指向最后一行

        last_row = Range("a65536").End(xlUp).Row + 1

        '对文件名字符串进行分割，按扩展名筛选需要提取的文件

        If InStr(Split(file.Name, ".")(UBound(Split(file.Name, "."))), "xlsx") > 0 Then

            '将文件路径保存在A列单元格中

            Range("a" & last_row) = fso.path & "\"

            '文件名保存在B列单元格中

            Range("b" & last_row) = file.Name

            'ws.Hyperlinks.Add anchor:=ws.Cells(last_row, 2), Address:=fso.Path & "\" & file.Name

        End If

    Next

    

    '第二部分，对目标文件夹子目录中的文件对象进行递归提取信息

    For Each Folder In fso.SubFolders

        Call get_folder_file(Folder.path)

    Next

    

    '释放变量

    Set fso = Nothing

End Function

'主程序

Sub 获取文件名和存储路径()

    Dim path As String

    '设置工作簿为当前文件

    Set wb = Workbooks(1)

    '设置提取信息要保存的工作表名称

    Set ws = Worksheets("文件列表")

    '填入标题行

    ws.Cells(1, 1).Value = "目录"

    ws.Cells(1, 2).Value = "文件"

    '要提取文件的根目录

    path = "D:\Temp\test5\"

    '调用函数提取信息

    Call get_folder_file(path)

    '释放变量

    Set ws = Nothing

    Set wb = Nothing

    MsgBox "处理完成。"

End Sub

4.实现效果

可以看到子目录中的文件也提取出来了，而且很容易看到，子目录中的文件名中在扩展名前多出了1个空格，在资源管理器中是很难发现的。