Sub folder()
Application.ScreenUpdating = False
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"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
TrailingMinusNumbers:=True
'A到G列自动列宽
Dim i, n
i = Range("a65536").End(xlUp).Row
For n = 2 To i
Range("b" & n).Select
ActiveSheet.Hyperlinks.add Anchor:=Selection, Address:=Cells(n, 1) & "\" & Cells(n, 2) Next
Columns("a:g").AutoFit
Application.ScreenUpdating = True
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
WorksheetFunction.Transpose(d.keys)
Else
Exit Sub
End If
Set d = Nothing
Set e = Nothing
Set f = Nothing
End Sub + 1).Resize(fc.Count, 1) =