vba cad 获取宏的路径_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 PathShtEnd 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 LoopEnd 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 IfEnd Function

最后提个醒:

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