如何将文件夹及子文件夹的文件做成目录？

楼主 wqfzqgk	Q:如何将文件夹及子文件夹的文件做成目录？ A:用递归的方式将文件夹及子文件夹中的文件导入到EXCEL中，再将导入的文件加上链接及文件大小等文件目录.rar Sub CreateMBCMenu()'创建菜单 On Error GoTo Err_Handler'有错误执行到Err_Handler '定义变量 Dim MyMnu As CommandBarControl Dim MyCtrl(1 To 1) As CommandBarControl Dim i As Integer Call DeleteMBCMenu'先删除菜单，如果有的话 Set MyMnu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, Temporary:=True)'创建菜单 With MyMnu .Caption = "文件目录" .BeginGroup = False .Enabled = True .Visible = True End With Set MyCtrl(1) = MyMnu.Controls.Add(Type:=msoControlButton, Temporary:=True) With MyCtrl(1) .BeginGroup = False .Caption = "文件目录" .Enabled = True .Visible = True .Style = msoButtonCaption .OnAction = "folder" End With For i = 1 To 1 Set MyCtrl(i) = Nothing'销毁 Next i Set MyMnu = Nothing Exit Sub Err_Handler: MsgBox Err.Description, vbExction End Sub '删除自定义菜单 Sub DeleteMBCMenu() On Error Resume Next Application.CommandBars("Worksheet Menu Bar").Controls("文件目录").Delete End Sub Sub CreateMBCBar()'创建工具栏 On Error GoTo Err_Handler Dim MyBar As CommandBar Dim MyCtrl(1 To 1) As CommandBarControl Dim i As Integer Call DeleteMBCBar Set MyBar = Application.CommandBars.Add(Name:="文件目录", Temporary:=True) MyBar.Visible = True Set MyCtrl(1) = MyBar.Controls.Add(Type:=msoControlButton, Temporary:=True) With MyCtrl(1) .BeginGroup = False .Caption = "文件目录" .Enabled = True .Visible = True .Style = msoButtonCaption End With For i = 1 To 1 Set MyCtrl(i) = Nothing Next i Set MyBar = Nothing Exit Sub Err_Handler: MsgBox Err.Description, vbExction End Sub '删除自定义工具栏 Sub DeleteMBCBar() On Error Resume Next Application.CommandBars("文件目录").Delete End Sub Sub folder() Cells.Clear '清除当前表的内容 Dim folder As FileDialog '定义变量 Set folder = Application.FileDialog(msoFileDialogFolderPicker) '取浏览窗口之文件夹名称 With folder .AllowMultiSelect = False '多选取消 If .Show = -1 Then folderpath = .SelectedItems(1) '当前所选文件夹 End With Call ShowFolderList(folderpath) '调用ShowFolderList显示当前文件夹中的文件 Call subfolder(folderpath) '调用ShowFolderList显示当前文件夹子文件夹中的文件 '当前工作表中 Range("a1") = "所在文件夹/文件名：/大小/最后修改时间/类型" '为A本赋值 Columns("a:a").Select '选择A列 '以下为A列分列操作 Selection.TextToColumns Destination:=Range("A1"), OtherChar :="/" 'A到G列自动列宽 Columns("a:g").AutoFit End Sub Sub subfolder(folderpath) If folderpath <> "" Then Set fs = CreateObject("scripting.filesystemobject") '创建调用脚本 Set f = fs.GetFolder(folderpath) '调用文件夹中的子文件夹 Set fss = f.SubFolders For Each subf In fss subfolder (subf) '递归调用 ShowFolderList (subf) '调用子程序显示子文件夹中文件 Next Else Exit Sub End If End Sub Sub ShowFolderList(folderspec) On Error Resume Next Dim fs, f, f1, fc, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set fc = f.Files If fc.Count <> 0 Then Set d = CreateObject("scripting.dictionary") For Each f1 In fc d.Add f1.ParentFolder & "/" & f1.Name & "/" & Int(f1.Size / 1024) & "KB" & "/" & f1.DateCreated & "/" & f1.Type, "" Next Range("a" & [a65536].End(xlUp).Row + 1).Resize(fc.Count, 1) = WorksheetFunction.Transpose(d.keys) Else Exit Sub End If Set d = Nothing Set e = Nothing Set f = Nothing End Sub
2楼 wangzhongtu	收藏了
3楼 7786910	观摩学习。
4楼 UXUXUX	有视频吗？版主可以发个视频学下吗
5楼飝嬿尐愺	感谢一下，先去试试看，好用不？
6楼 wpppj	好东西，能提取出全部的文件并罗列出来，没办法把每个文件夹的内容分类
7楼 akinoru	这个小东西很方便列出目录下文件.rar
8楼 gysegz	怎么不能自动链接呀
9楼 qinhuan66	好好学习天天向上
10楼 kszcs	收藏，学习
11楼 icenotcool
12楼 icenotcool