Sub GrabFiles()
Dim strPathFile As String
Dim xDirect$, xFname$, InitialFoldr$, xLocation
Application.ScreenUpdating = False
'Update today's date
Range("C1").Formula = "Updated on:"
Range("D1").Formula = "=Today()"
Range("D1").Copy
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
InitialFoldr$ = ""
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1)
ListFilesInFolder xDirect$, True
End If
End With
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder,
SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
Cells(r, 1).Formula = FileItem.Path
'Space for Link
Cells(r, 3).Formula = FileItem.Name
'Space for Description
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateCreated
Cells(r, 8).Formula = FileItem.DateLastModified
r = r + 1
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Range("A2").Select
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
Range("D3:D1000").EntireRow.AutoFit
End Sub
Bookmarks