I did the project with code below for someone just interested in the file
names and date information but it should be very simple to add file size or
other parameters you might want...Steve
First Create a reference to "Microsoft Scripting Runtime" (Tools >
References) in VBE.
In module 1:
Sub DoNewFolder()
Workbooks.Add
Dim fd As FileDialog
Dim strPath As String
Dim B As Integer
Dim IncludeSubfolders As Boolean
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim selFldr As Variant
With fd
If .Show = -1 Then
For Each selFldr In .SelectedItems
strPath = selFldr & "\"
Next selFldr
Else
End If
End With
IncludeSubfolders = False
B = MsgBox("Include Subfolders?", vbYesNo, "Scope")
If B = 6 Then
IncludeSubfolders = True
Else
IncludeSubfolders = False
End If
With Range("A1")
.Formula = "Folder Contents: " & strPath
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = " "
Range("B3").Formula = "File Name"
Range("C3").Formula = "Date Created"
Range("D3").Formula = "Date Last Modified"
Range("E3").Formula = "Date Last Accessed"
Range("A3:E3").Font.Bold = True
ListFilesInFolder strPath, IncludeSubfolders
Range("A2").Select
End Sub
Sub ListFilesInFolder(SourceFolderName As String, AlsoSubfolders 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 = " "
Cells(r, 2).Formula = FileItem.Name
Cells(r, 3).Formula = FileItem.DateCreated
Cells(r, 4).Formula = FileItem.DateLastModified
Cells(r, 5).Formula = FileItem.DateLastAccessed
r = r + 1
Next FileItem
If AlsoSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
r = Range("A65536").End(xlUp).Row + 1
Cells(r, 1).Formula = SubFolder.Path
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("B:E").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Under "ThisWorkbook":
Private Sub Workbook_Open()
Workbooks.Add
Dim fd As FileDialog
Dim strPath As String
Dim B As Integer
Dim IncludeSubfolders As Boolean
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim selFldr As Variant
With fd
If .Show = -1 Then
For Each selFldr In .SelectedItems
strPath = selFldr & "\"
Next selFldr
Else
End If
End With
IncludeSubfolders = False
B = MsgBox("Include Subfolders?", vbYesNo, "Scope")
If B = 6 Then
IncludeSubfolders = True
Else
IncludeSubfolders = False
End If
With Range("A1")
.Formula = "Folder Contents: " & strPath
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = " "
Range("B3").Formula = "File Name"
Range("C3").Formula = "Date Created"
Range("D3").Formula = "Date Last Modified"
Range("E3").Formula = "Date Last Accessed"
Range("A3:E3").Font.Bold = True
ListFilesInFolder strPath, IncludeSubfolders
Range("A2").Select
End Sub
