Option Explicit
   

    Sub GetAllFiles()
    
        Dim pth$, arr, i%, r%
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = -1 Then
                pth = .SelectedItems(1)
            Else
                MsgBox "您没有选择任何文件夹！", vbCritical: Exit Sub
            End If
        End With
        ReDim arr(1 To 6, 1 To 1)
        arr(1, 1) = "文件名称"
        arr(2, 1) = "文件位置"
        arr(3, 1) = "创建日期"
        arr(4, 1) = "修改日期"
        arr(5, 1) = "文件类型"
        arr(6, 1) = "文件大小"
        Getfd pth, arr
        arr = Application.WorksheetFunction.Transpose(arr) '文件信息已保存在arr数组中
        '实际使用时可不输出到工作表，直接在数组arr中查询需要的文件信息。以下10行可删除
        For i = 2 To UBound(arr)
            arr(i, 1) = "=hyperlink(""" & arr(i, 2) & """,""" & arr(i, 1) & """)"
        Next i
        Application.ScreenUpdating = False
        With ActiveSheet
            .UsedRange.Clear
            .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            r = .Range("a" & Rows.Count).End(3).Row
            .Range("a1:f" & r).Borders.LineStyle = xlContinuous
            .Range("a1:f" & r).Borders.Weight = xlThin
        End With
        Application.ScreenUpdating = True
        [a1].CurrentRegion.AutoFilter Field:=1   '输出结果到工作表，并启用筛选模式
        MsgBox "文件已全部获取！点『确定』键结束"
    End Sub

    Sub Getfd(ByVal pth As String, arr)
        Dim fso As Object, f, fd, ff, u
        Set fso = CreateObject("scripting.filesystemobject")
        Set ff = fso.GetFolder(pth)
        For Each f In ff.Files
            ReDim Preserve arr(1 To 6, 1 To UBound(arr, 2) + 1)
            u = UBound(arr, 2)
            arr(1, u) = f.Name
            arr(2, u) = f
            arr(3, u) = f.DateCreated
            arr(4, u) = f.DateLastModified
    '        arr(5, u) = f.Type
    Rem 将文件类型修改为文件后缀名     2019-4-15  19:35
           arr(5, u) = Mid(f.Name, InStrRev(f.Name, ".", -1, 1) + 1)
           arr(6, u) = Format(f.Size / 1048576, "0.00MB")
        Next
        For Each fd In ff.SubFolders: Getfd fd, arr: Next
       
    End Sub