Option Explicit
Sub ListFiles()
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select directory"
.InitialFileName = ThisWorkbook.Path & "\"
.AllowMultiSelect = False
If .Show = 0 Then Exit Sub
sPath = .SelectedItems(1) & "\"
End With
NoCursing sPath, Range("A1")
End Sub
Sub NoCursing(ByVal sPath As String, rOut As Range)
' lists file name, size, and date for the files in and below sPath
' in columns A:C of rOut
' attribute mask
Const iAttr As Long = vbNormal + vbReadOnly + vbSystem + vbDirectory
Dim jAttr As Long ' file attributes
Dim col As Collection ' queued directories
Dim iFile As Long ' file counter
Dim sFile As String ' file name
Dim sName As String ' full file name
Dim fSec As Single ' seconds since midnight
Dim maxRows As Long
Dim sheetNumber As Integer
maxRows = 1048576
With rOut.Range("A1:C1").Resize(rOut.Worksheet.Rows.Count - rOut.Row + 1)
.ClearContents
.Rows(1).Value = Split("File,Date,Size", ",")
End With
Application.ScreenUpdating = False
fSec = Timer
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Set col = New Collection
col.Add sPath
Do While col.Count
sPath = col(1)
On Error Resume Next
sFile = Dir(sPath, iAttr)
Do While Len(sFile)
sName = sPath & sFile
On Error Resume Next
jAttr = GetAttr(sName)
If Err.Number Then
' You can't get attributes for files with Unicode characters in
' the name, or some particular files (e.g., "C:\System Volume Information")
Debug.Print sName
Err.Clear
Else
On Error GoTo 0
If jAttr And vbDirectory Then
If Right(sName, 1) <> "." Then col.Add sName & "\"
Else
iFile = iFile + 1
If (iFile And &H3FF) = 0 Then
Application.StatusBar = sMsg(iFile, Timer - fSec, col.Count)
DoEvents
End If
If iFile = maxRows Then
sheetNumber = sheetNumber + 1
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sheet-" & sheetNumber
iFile = 1
End If
iFile = iFile + 1
rOut.Range("A1:C1").Offset(iFile).Value = Array(sName, _
FileDateTime(sName), _
FileLen(sName))
End If
End If
sFile = Dir()
Loop
col.Remove 1
Loop
iFile = iFile + 1
rOut.Offset(iFile).Value = sMsg(iFile - 1, Timer - fSec, col.Count)
rOut.CurrentRegion.Sort Key1:=rOut.Range("A1"), Header:=xlYes
Columns.AutoFit
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Function sMsg(nFile As Long, fSec As Single, nCol As Long) As String
sMsg = " Files listed: " & Format(nFile, "#,##0") & _
" ET: " & Format(fSec / 86400, "h:mm:ss") & _
" Files/s: " & Format(nFile / fSec, "0") & _
" Directories queued: " & nCol
End Function
