Option Explicit 
 
Sub SrchForFiles() 
     ' Searches the selected folders and sub folders for files with the specified
     'extension.  .xls, .doc, .ppt, etc.
     'A new worksheet is produced called "File Search Results".  You can click on the link and go directly
     'to the file you need.
    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", "Info Request") 
    If y = False And Not TypeName(y) = "String" Then Exit Sub 
    Application.ScreenUpdating = False 
     '**********************************************************************
     'fLdr = BrowseForFolderShell
    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) 
                 'Get file path from file name
                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:D1] 
            .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