Fill Listbox With Found Files

[Jaye7]

I found the following script to open found files, however can someone please adapt the script so that rather than open the files it actually lists the file name in listbox1 of userform1 and lists the file path in listbox2.

Thanks

With Application.FileSearch
  .NewSearch
  .LookIn = "I:\IsolationDataBase\IsolationProcedures"
    .SearchSubFolders = True
    .Filename = Range("A1").Value
    .MatchTextExactly = True
    .FileType = msoFileTypeAllFiles
    If .Execute() > 0 Then
      For j = 1 To .FoundFiles.Count
        Workbooks.Open Filename:=.FoundFiles(j)
      Next j
    Else
      MsgBox "file Not found"
    End If
 
End With

 

[Jaye7]

Thanks Phil,

It is working except that it is not picking up the value in cell A1, I have to type the actual file name and extension i.e. budget.xls in the msgbox that pops up when I run the script otherwise if I was to type budget, it returns every single file in the folder as it must be just looking for all files, rather than the actual filename, that's OK, I can work with it.
Thanks again.

 

[pbornemeier]

Change this line:

strFileName = InputBox("Enter the filename or pattern (wildcards OK) to search for", "Search for", "*.*")
to
If Len(strFileName) = 0 then strFileName = "*.*"
strFileName = InputBox("Enter the filename or pattern (wildcards OK) to search for", "Search for", strFileName)

 

[Jaye7]

Hello again Phil,

One more thing with the script that you provided.

Are you able to provide a script that would put the file path/location in column2 of listbox 1 (instead of in listbox2), so that I can then use a commandbutton script to open the file that I select.

Thanks

 

[pbornemeier]

Be sure the listbox1.ColumnCount is set to 2

Listbox is sorted in filename order, ignoring directories.

Option Explicit
 
Global aryFoundFiles() As Variant
 
Sub PopulateListBoxWithFiles()
    'Searches I:\IsolationDataBase\IsolationProcedures for filename.ext pattern (wildcards OK) in cell A1
    'If no pattern in A1 then *.* is used to return all files.
 
    'Add reference to Microsoft Scripting Runtime (VBA editor: Tools | References)
 
    'Calls ReturnFilePathNameArray
 
    Dim aryFilenames() As Variant
    Dim strFileName As String
    Dim strPath As String
    Dim booSame As Boolean
    Dim intX As Integer
    Dim intY As Integer
    Dim strFileDirectory As String
    Dim strSort1 As String
    Dim strSort2 As String
 
    strFileDirectory = "I:\IsolationDataBase\IsolationProcedures"
    strFileName = Range("A1").Value
 
    'Select Directory  - "Uncomment section below to allow a directory to be chosen at runtime
'    With Application.FileDialog(msoFileDialogFolderPicker)
'        .Title = "Select the directory"
'        .AllowMultiSelect = False
'        .ButtonName = "Select"
'        .InitialFileName = ThisWorkbook.Path
'        .Show
'        If .SelectedItems.Count > 0 Then
'            strFileDirectory = .SelectedItems.Item(1)
'        End If
'    End With
    'Verify the A1 value is the desired filename
    strFileName = InputBox("Enter the filename or pattern (wildcards OK) to search for", "Search for", "*.*")
 
    'Next code line checks for existance of filename and defaults to *.* if it is not present
    'more checks should be added to ensure only valid filenames are used.
    If strFileName = "" Then strFileName = "*.*"
 
    UserForm1.ListBox1.Clear
 
    ReturnFilePathNameArray strFileDirectory, strFileName
 
    If Len(aryFoundFiles(1, 1)) = 0 Then
        'Do nothing - error msgbox was displayed by 'ReturnFilePathNameArray' procedure
    Else
 
        aryFilenames = aryFoundFiles
 
        For intX = 1 To UBound(aryFilenames, 2)
            'Copy path to second element of array
            aryFilenames(2, intX) = Left(aryFilenames(1, intX), InStrRev(aryFilenames(1, intX), "\"))
            'Remove path from aryFilenames
            aryFilenames(1, intX) = Mid(aryFilenames(1, intX), InStrRev(aryFilenames(1, intX), "\") + 1, 100)
        Next
 
        'Sort array by filenames, ignoring path
        For intX = 1 To UBound(aryFilenames, 2)
           For intY = intX To UBound(aryFilenames, 2)
                If UCase(aryFilenames(1, intY)) < UCase(aryFilenames(1, intX)) Then
                    strSort1 = aryFilenames(1, intX)
                    strSort2 = aryFilenames(1, intY)
                    aryFilenames(1, intX) = strSort2
                    aryFilenames(1, intY) = strSort1
                End If
            Next intY
        Next intX
 
        booSame = True
        strPath = aryFilenames(2, 1)
        For intX = 2 To UBound(aryFilenames, 2)
            If strPath <> aryFilenames(2, intX) Then
                booSame = False
                Exit For
            End If
        Next
 
        If booSame Then 'All files returned are in the same directory
            UserForm1.ListBox2.List = Array(strPath) 'Display common path in listbox2
        Else
            UserForm1.ListBox2.List = Array("Multiple Directories Returned (" & UBound(aryFilenames, 2) & ") files.")
        End If
 
        UserForm1.ListBox1.List = Application.Transpose(aryFilenames)
        UserForm1.Show (vbModeless)
 
    End If
End_Sub:
 
End Sub
 
Sub ReturnFilePathNameArray(strPath As String, strFileLike As String)
    'Calls GetFiles
 
    Dim fso As FileSystemObject 'Add reference to Microsoft Scripting Runtime
    ReDim aryFoundFiles(1 To 2, 1 To 1)
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    GetFiles fso, strPath, strFileLike
 
    If UBound(aryFoundFiles, 2) = 1 Then
        MsgBox "No files were returned for this starting directory: " & strPath & vbLf & _
            "and this file pattern: " & strFileLike
    Else
        ReDim Preserve aryFoundFiles(1 To 2, 1 To UBound(aryFoundFiles, 2) - 1)
    End If
 
    Set fso = Nothing
 
End Sub
 
Sub GetFiles(fso As FileSystemObject, strPath As String, strFilePattern As String)
    'Add reference to Microsoft Scripting Runtime
 
    Dim fldr As Folder
    Dim fldrSub As Folder
    Dim oFile As Object
 
    Set fldr = fso.GetFolder(strPath)
 
    If fldr.Files.Count > 0 Then
        For Each oFile In fldr.Files
            If UCase(oFile.Name) Like UCase(strFilePattern) Then 'UCase makes search case insensitive
                aryFoundFiles(1, UBound(aryFoundFiles, 2)) = oFile.Path
                ReDim Preserve aryFoundFiles(1 To 2, 1 To UBound(aryFoundFiles, 2) + 1)
            Else
                Debug.Print oFile.Path
            End If
        Next
    End If
    If fldr.SubFolders.Count > 0 Then
        For Each fldrSub In fldr.SubFolders
            GetFiles fso, fldrSub.Path, strFilePattern
        Next
    End If
 
    Set fldr = Nothing
End Sub

 

[Jaye7]

Brilliant, Thanks Phil, the script now does exactly what I want it to do.