VBA Directory File Search using list within Excel

Question

I'm currently trying to edit a macro a colleague of mine currently uses, the script currently opens a message box that allows you to enter in a string, which is then searched for and results are pasted into the workbook. I would like to change this so it searches for a list already within the spreadsheet, and then for the results to be pasted on the next worksheet. I'm not sure if this is actually possible or not, which is where my main struggle is. Below is the current code, I assume all that is needed is for the variable range to be placed in that stars "msg = "Enter file name and Extension"

Sub Filesearch()
 Dim myDir As String, temp(), myList, myExtension As String
    Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        End If
    End With
    msg = "Enter File name and Extension" & vbLf & "following wild" & _
    " cards can be used" & vbLf & "* # ?"
    myExtension = Application.InputBox(msg)
    If (myExtension = "False") + (myExtension = "") Then Exit Sub
    Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
    SearchSubFolders = Rtn = 6
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
    If Not IsError(myList) Then
        Sheets(1).Cells(1).Resize(UBound(myList, 2), 2).Value = _
        Application.Transpose(myList)
    Else
        MsgBox "No file found"
    End If
End Sub


Private Function SearchFiles(myDir As String _
    , myFileName As String, n As Long, myList() _
    , Optional SearchSub As Boolean = False) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.getfolder(myDir).Files
        Select Case myFile.Attributes
        Case 2, 4, 6, 34
        Case Else
            If (Not myFile.Name Like "~$*") _
            * (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _
            * (UCase(myFile.Name) Like UCase(myFileName)) Then
                n = n + 1
                ReDim Preserve myList(1 To 2, 1 To n)
                myList(1, n) = myDir
                myList(2, n) = myFile.Name
            End If
        End Select
    Next
    If SearchSub Then
        For Each myFolder In fso.getfolder(myDir).subfolders
            SearchFiles = SearchFiles(myFolder.Path, myFileName, _
            n, myList, SearchSub)
        Next
    End If
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function

Certainly, It's possible to perform a search from a list in a worksheet. However, what this list will be holding as currently you have 3 input from users i.e. Folder, FileMask & include subfolders. Provide more info on what you have done so far, and what sort of issues have encountered. — EEM
– EEM, Commented May 21, 2015 at 22:02

2 revs · Accepted Answer · 2015-05-21 22:52:18Z

Suggest the use of Defined Name Ranges to hold the user maintained list (as show in the picture below)

enter image description here

Let’s add a worksheet for user input of the requirements called “_Tables”. Then create Defined Name Ranges, for users to enter the requirements, called "_Path", "_Files" and "_SubFldrs"

Then replace all the user’s input in current code

REPLACE THIS
'''    With Application.FileDialog(msoFileDialogFolderPicker)
'''        If .Show Then
'''            myDir = .SelectedItems(1)
'''        End If
'''    End With
'''    msg = "Enter File name and Extension" & vbLf & "following wild" & _
'''    " cards can be used" & vbLf & "* # ?"
'''    myExtension = Application.InputBox(msg)
'''    If (myExtension = "False") + (myExtension = "") Then Exit Sub
'''    Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
'''    SearchSubFolders = Rtn = 6

with this in order to read the requirements from the worksheet "_Tables"

    Set WshLst = ThisWorkbook.Sheets("_Tables")
    sPath = WshLst.Range("_Path").Value2
    aFleKey = WshLst.Range("_Files").Value2
    bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES")
    aFleKey = WorksheetFunction.Transpose(aFleKey)

then Process the lists See below the entire code below. It's necessary to have the statement Option Base 1 at the top of the module

Option Explicit
Option Base 1

Sub Fle_FileSearch_List()
Dim WshLst As Worksheet
Dim sPath As String
Dim aFleKey As Variant, vFleKey As Variant
Dim bSbFldr As Boolean
Dim vFleLst() As Variant
Dim lN As Long

    Set WshLst = ThisWorkbook.Sheets("_Tables")
    sPath = WshLst.Range("_Path").Value2
    aFleKey = WshLst.Range("_Files").Value2
    bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES")
    aFleKey = WorksheetFunction.Transpose(aFleKey)

    Rem To clear output location
    ThisWorkbook.Sheets(1).Columns(1).Resize(, 2).Clear

    Rem Process input list
    For Each vFleKey In aFleKey
        If (vFleKey <> "False") * (vFleKey <> "") Then
        Call Fle_FileSearch_Fldrs(sPath, CStr(vFleKey), lN, vFleLst, bSbFldr)
    End If: Next

    Rem Validate Results & List Files found
    If lN > 1 Then
        ThisWorkbook.Sheets(1).Cells(1).Resize(UBound(vFleLst, 2), 2) _
            .Value = Application.Transpose(vFleLst)
    Else
        MsgBox "No file found"
    End If

End Sub

Also some adjustments to the function (now a procedure) to allow the process of the list.

Sub Fle_FileSearch_Fldrs(sPath As String, _
    sFleKey As String, lN As Long, vFleLst() As Variant, _
    Optional bSbFldr As Boolean = False)

Dim oFso As Object, oFolder As Object, oFile As Object

    Set oFso = CreateObject("Scripting.FileSystemObject")

    If lN = 0 Then
        lN = 1 + lN
        ReDim Preserve vFleLst(1 To 2, 1 To lN)
        vFleLst(1, lN) = "Files Found - Path"
        vFleLst(2, lN) = "Files Found - Name"
    End If

    For Each oFile In oFso.GetFolder(sPath).Files
        Select Case oFile.Attributes
        Case 2, 4, 6, 34    
        Case Else
            If (Not oFile.Name Like "~$*") * _
                (oFile.Path & "\" & oFile.Name <> ThisWorkbook.FullName) * _
                (UCase(oFile.Name) Like UCase(sFleKey)) Then

                lN = lN + 1
                ReDim Preserve vFleLst(1 To 2, 1 To lN)
                vFleLst(1, lN) = sPath
                vFleLst(2, lN) = oFile.Name

    End If: End Select: Next

    If bSbFldr Then
        For Each oFolder In oFso.GetFolder(sPath).subfolders
            Call Fle_FileSearch_Fldrs(oFolder.Path, sFleKey, lN, vFleLst, bSbFldr)
    Next: End If

End Sub

Collectives™ on Stack Overflow

VBA Directory File Search using list within Excel

1 Answer 1

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Related