This is the larger procedure...
--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown

Option Explicit


'/================================/
' Sub Purpose:
' History:
' 07/15/2000 added hyperlink
' 07/17/2000 added filename filter
' 07/20/2000 added # files found info & criteria info
' 07/27/2000 added extension as separate column
' 08/03/2000 changed # files found to 'count' formula
' 10/23/2000 add status bar 'Wait' message
' 01/18/2007 change to FileDialog property
' 05/14/2009 change from FileSearch to recursive DIR
' for 2007 comparability (Dir Recursive
' basic concept from MrExcel.com)
'
'/================================/
'
Public Sub ListFilesToWorksheet()
Dim blnSubFolders As Boolean
Dim dblLastRow As Long
Dim R As Integer, x As Integer
Dim y As Integer, iWorksheets As Integer
Dim i As Long, j As Long, k As Long
Dim fso As Object
Dim Msg As String, strDirectory As String, strPath As String
Dim strResultsTableName As String, strFileName As String
Dim strWorksheetName As String
Dim strArr() As String
Dim strName As String
Dim strFileNameFilter As String, strDefaultMatch As String
Dim strExtension As String, strFileBoxDesc As String
Dim strMessage_Wait1 As String, strMessage_Wait2 As String
Dim varSubFolders As Variant, varAnswer As String

On Error Resume Next

'- - - - V A R I A B L E S - - - - - - - - -
strResultsTableName = "File_Listing"
strDefaultMatch = "*.*"
R = 1
i = 1
blnSubFolders = False
strMessage_Wait1 = _
"Please wait while search is in progress..."
strMessage_Wait2 = _
"Please wait while formatting is completed..."
ReDim strArr(1 To 65536, 1 To 3)
'- - - - - - - - - - - - - - - - - - - - - -

strFileNameFilter = _
InputBox("Ex: *.* with find all files" & vbCr & _
" blank will find all Office files" & vbCr & _
" *.xls will find all Excel files" & vbCr & _
" G*.doc will find all Word files beginning with G" _
& vbCr & _
" Test.txt will find only the files named TEST.TXT" _
& vbCr, _
"Enter file name to match:", Default:=strDefaultMatch)

If Len(strFileNameFilter) = 0 Then
varAnswer = _
MsgBox("Continue Search?", vbExclamation + vbYesNo, _
"Cancel or Continue...")
If varAnswer = vbNo Then
GoTo Exit_ListFiles
End If
End If

If Len(strFileNameFilter) = 0 Then
strFileBoxDesc = "*.*"
strFileNameFilter = "*.*"
Else
strFileBoxDesc = strFileNameFilter
End If

Msg = "Select location of files to be " & _
"listed or press Cancel."

'Allow user to select folder(s)
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = Left(ActiveWorkbook.FullName, _
Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.name))
.Title = Msg
.Show
strDirectory = .SelectedItems(1)
End With

If strDirectory = "" Then
Exit Sub
End If

If Right(strDirectory, 1) < Application.PathSeparator Then
strDirectory = strDirectory & Application.PathSeparator
End If

varSubFolders = _
MsgBox("Search Sub-Folders of " & strDirectory & " ?", _
vbInformation + vbYesNoCancel, "Search Sub-Folders?")

If varSubFolders = vbYes Then blnSubFolders = True
If varSubFolders = vbNo Then blnSubFolders = False
If varSubFolders = vbCancel Then Exit Sub

'check for an active workbook
' if no workbooks open, create one
If ActiveWorkbook Is Nothing Then
Workbooks.Add
End If

'save name of current worksheet
strWorksheetName = ActiveSheet.name

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
Exit For
End If
Next

'Add new worksheet where results will be located
Worksheets.Add.Move after:=Worksheets(ActiveSheet.name)

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Hyperlink"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Path"
ActiveWorkbook.ActiveSheet.Range("C1").value = "FileName"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Extension"
ActiveWorkbook.ActiveSheet.Range("E1").value = "Size"
ActiveWorkbook.ActiveSheet.Range("F1").value = "Date/Time"
Range("A1:E1").Font.Bold = True

R = R + 1

'get 1st filename
strName = Dir(strDirectory & strFileNameFilter)

On Error Resume Next
Application.StatusBar = strMessage_Wait1

'put filenames and file info into array
Do While strName < vbNullString
k = k + 1
strArr(k, 1) = strDirectory & strName
strArr(k, 2) = FileLen(strDirectory & strName)
strArr(k, 3) = FileDateTime(strDirectory & "\" & strName)
strName = Dir()
Loop

'get subfolder filenames if subfolder option selected
If blnSubFolders Then
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDirectory), _
strArr(), k, strFileNameFilter)
End If

'put file info on worksheet
If k 0 Then
For i = 1 To k
strFileName = ""
strPath = ""
For y = Len(strArr(i, 1)) To 1 Step -1
If Mid(strArr(i, 1), y, 1) = _
Application.PathSeparator Then
Exit For
End If
strFileName = _
Mid(strArr(i, 1), y, 1) & strFileName
Next y
strPath = _
Left(strArr(i, 1), _
Len(strArr(i, 1)) - Len(strFileName))
strExtension = ""
For y = Len(strFileName) To 1 Step -1
If Mid(strFileName, y, 1) = "." Then
If Len(strFileName) - y < 0 Then
strExtension = Right(strFileName, _
Len(strFileName) - y + 1)
' strExtension = Right(strFileName, _
Len(strFileName) - y)
strFileName = Left(strFileName, y - 1)
Exit For
End If
End If
Next y
Cells(R, 1) = strArr(i, 1)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(R, 1), _
Address:=strArr(i, 1)
Cells(R, 2) = strPath
Cells(R, 3) = strFileName
Cells(R, 4) = strExtension
Cells(R, 5) = FileLen(strArr(i, 1))
Cells(R, 6) = FileDateTime(strArr(i, 1))
R = R + 1
Next i
End If

'formatting
Application.StatusBar = strMessage_Wait2
ActiveWindow.Zoom = 75
Columns("E:E").Select
With Selection
.NumberFormat = _
"_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
End With
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Columns("A:F").EntireColumn.AutoFit
Columns("A:A").Select
If Selection.ColumnWidth 12 Then
Selection.ColumnWidth = 12
End If

Range("A2").Select
ActiveWindow.FreezePanes = True

Rows("1:1").Select
Selection.Insert Shift:=xlDown

dblLastRow = 65000

ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
If Len(strFileNameFilter) = 0 Then
strFileNameFilter = "*.*"
End If
If blnSubFolders Then
strDirectory = "(including Subfolders) - " & strDirectory
End If

Application.ActiveCell.Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & _
" files(s) found for Criteria: " & _
strDirectory & strFileNameFilter & Chr(34)
Selection.Font.Bold = True

Range("B3").Select
Selection.Sort Key1:=Range("B3"), _
Order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom

Range("A3").Select

Application.Dialogs(xlDialogWorkbookName).Show

Exit_ListFiles:
Application.StatusBar = False
Exit Sub

Err_ListFiles:
MsgBox "Error: " & Err & " - " & Err.Description
Resume Exit_ListFiles

End Sub

'/================================/
' Sub Purpose: recursive for filesearch 2007
'/================================/
'
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long, _
ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String

On Error GoTo err_Sub

For Each SubFolder In Folder.SubFolders
'get 1st filename in subfolder
strName = Dir(SubFolder.Path & "\" & searchTerm)
'put filenames and file info in subfolders into array
Do While strName < vbNullString
i = i + 1
strArr(i, 1) = SubFolder.Path & "\" & strName
strArr(i, 2) = FileLen(SubFolder.Path & "\" & strName)
strArr(i, 3) = FileDateTime(SubFolder.Path & "\" & strName)
strName = Dir()
Loop
Call recurseSubFolders(SubFolder, strArr(), i, searchTerm)
Next

exit_Sub:
On Error Resume Next
Exit Sub

err_Sub:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: recurseSubFolders - Module: " & _
"Mod_Testing - " & Now()
GoTo exit_Sub

End Sub
'/================================/