Try this. Allows you to select file extension or serach on all files and then
select search folder. Puts the results in a new worksheet but that would be
easily changed:-
Option Explicit
Sub SrchForFiles()
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String
y = Application.InputBox("Please Enter File Extension - leave blank for
all files", "Info Request")
If y = False And Not TypeName(y) = "String" Then Exit Sub
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fLdr = .SelectedItems(1)
End With
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = True
.Filename = y
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error GoTo 1
2: ws.Name = "FileSearch Results"
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Fil = .FoundFiles(i)
FPath = Left(Fil, Len(Fil) - Len(Split(Fil,
"\")(UBound(Split(Fil, "\")))) - 1)
If Left$(Fil, 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(Fil))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 4) = _
Array(Dir(Fil), _
FileLen(Fil) / 1000, _
FileDateTime(Fil), _
FPath)
ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
End If
End With
ActiveWindow.DisplayHeadings = False
With ws
Rw = .Cells.Rows.Count
With .[A1
1]
.Value = [{"Full Name","Kilobytes","Last Modified", "Path"}]
.Font.Underline = xlUnderlineStyleSingle
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[E1:IV1 ].EntireColumn.Hidden = True
On Error Resume Next
Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden =
True
Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
Mike
