CODEWITHSUNDEEP
excelvba
ASD
ASD

Reputation: 65

Excel VBA search subfolders

This is what i got, it works, but it doesn't search the subfolders of "K:". What am i doing wrong?

Sub Search()

    Dim RGFileName As String
    Dim RGNumber As String
    Dim Path As String
    Path = "K:\"
    RGNumber = InputBox("Input RG-Number (33xxxx)", "RG-Number")
    RGFileName = Dir(Path & "*" & RGNumber & "*.xlsm")
    If RGFileName <> "" Then
        Workbooks.Open Path & RGFileName
    End If
End Sub

Upvotes: 0

Views: 239

Answers (1)

Tim Williams
Tim Williams

Reputation: 166156

Using a separate function to perform the search - returns a collection of File objects:

Sub Search()

    Dim RGFileName As String
    Dim RGNumber As String
    Dim Path As String, allFiles As Collection
    
    Path = "K:\"
    RGNumber = InputBox("Input RG-Number (33xxxx)", "RG-Number")
    
    Set allFiles = GetMatches(Path, "*" & RGNumber & "*.xlsm")
    If allFiles.Count > 0 Then
        Workbooks.Open allFiles(1).Path
    Else
        MsgBox "No match"
    End If
    
End Sub


'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection
    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        For Each f In fldr.Files
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
    Loop
    Set GetMatches = colFiles
End Function

Edit: this will look for the first match and return the full path to the file

Function MatchFirstFile(startFolder As String, filePattern As String) As String
    Dim colSub As New Collection, f, fld
    colSub.Add startFolder
    Do While colSub.Count > 0
        fld = colSub(1)
        colSub.Remove 1
        f = Dir(fld, vbDirectory)
        Do While Len(f) > 0
            If GetAttr(fld & f) = vbDirectory Then
                If f <> "." And f <> ".." Then 'ignore parent and current folders
                    colSub.Add fld & f & "\"
                End If
            Else
                If UCase(f) Like UCase(filePattern) Then
                    MatchFile = fld & f
                    Exit Function
                End If
            End If
            f = Dir()
        Loop
    Loop
End Function

Upvotes: 1

Related Questions