Search Folders and Subfolders for files

If you have ever had to look through a large directory for files, this routine searches the directory and subfolders and displays them in a new worksheet. The files can be opened by clicking on the listed hyperlink.
This routine searches a directory and sub folders for a selected file type. They are displayed in a new worksheet.
Source: http://www.vbaexpress.com/
Code by : austenr

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", "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:=ws.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

Advertisements

1 Comment »

  1. […] Search Folders and Subfolders for files […]

RSS feed for comments on this post · TrackBack URI

Leave a Reply

Please log in using one of these methods to post your comment:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: