VBA批量创建文件目录及链接，建议收藏备用

小伙伴们，之前有跟大家分享过Power Query获取文件夹内文件清单及其属性的方法【Excel快速获取文件列表及文件属性】。今天教大家通过VBA代码来实现同样的功能，提取文件夹内的文件信息更加灵活，只要选择对应的文件夹即可。

操作方法：

1. 在Excel界面按快捷键ALT+F11进入VBE界面。

2. 在VBE工程里面插入一个模块。

3. 将以下代码复制到模块中。

4. 关闭VBE界面，返回Excel界面，从开发工具中找到表单控件，插入一个按钮。

5. 按钮指定宏[GetFileList]即可。

以下是实现本次功能要用到的VBA代码，有详细注解，应用非常广泛，建议收藏备用。

Sub GetFileList()
 '定义文件夹路径变量
 Dim PathSht As String
 '清空模板文件里面的数据
 ActiveSheet.Range("A3:H65536").Clear
 '调用文件路径获取方法，弹出文件夹选择对话框
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
 End With
 '先获取当前文件夹内的文件
 GetFileFromFolder PathSht & "\"
 '获取子文件夹内的文件
 GetFolderList PathSht
End Sub

'方法一：从文件夹里面提取文件和文件信息
Function GetFileFromFolder(folder_name)
 '定义文件操作对象
 Dim fso As Object
 '设置文件操作对象
 Set fso = CreateObject("Scripting.FileSystemObject")
 '所有文件类型，如果只要Excel文件则修改为 FileType = "*.xls*"
 FileType = "*.*"
 '查找第一个文件
 sPath = Dir(folder_name & FileType)
 '循环到没有文件为止
 Do While Len(sPath)
 '将文件对象赋值给objfile，方便后续获取对应属性数据
 Set objfile = fso.GetFile(folder_name & sPath)
 '当前活动工作表
 With ActiveSheet
 '定位到第一个空行位置
 endrow = .Range("A65536").End(xlUp).Row + 1
 'A列存放文件夹名称
 .Range("A" & endrow) = folder_name
 'B列存放文件名称
 .Range("B" & endrow) = sPath
 'C列存放文件类型
 .Range("C" & endrow) = objfile.Type
 'D列存放文件大小
 .Range("D" & endrow) = FormatNumber(objfile.Size / 1024, -1) & "K"
 'E列存放文件创建时间
 .Range("E" & endrow) = objfile.DateCreated
 'F列存放文件修改时间
 .Range("F" & endrow) = objfile.DateLastModified
 'G列存放文件访问时间
 .Range("G" & endrow) = objfile.Datelastaccessed
 'H列创建超链接，支持点击打开文件
 ActiveSheet.Hyperlinks.Add Anchor:=.Range("H" & endrow), Address:=folder_name & sPath, ScreenTip:="单击打开" & sPath, TextToDisplay:="打开文件"
 End With
 '查找下一个文件
 sPath = Dir
 Loop
End Function

'方法二：递归方式循环遍历子文件夹
Function GetFolderList(strFolder)
 '定义文件夹操作对象
 Dim fso, objFolder, objSubFolder
 '设置文件操作对象
 Set fso = CreateObject("Scripting.FileSystemObject")
 '判断文件夹是否存在
 If fso.FolderExists(strFolder) Then
 '定义为父文件夹
 Set objFolder = fso.getFolder(strFolder)
 '定义为子文件夹
 Set objSubFolder = objFolder.subFolders
 '每一个在父文件夹中的子文件夹
 For Each oSubFolder In objSubFolder
 '从文件夹里面获取文件
 GetFileFromFolder oSubFolder & "\"
 '继续获取当前文件夹的子文件夹
 GetFolderList oSubFolder.Path
 Next
 End If
End Function

最后提个醒:

别忘了把你的Excel文件另存为加载宏工作簿，这样才可变成永久可以的工具。