Add more extensions to UDF

[YasserKhalil]

Hello erveyone
I have found the following UDF

Code: Select all

Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As String

    Dim StrFile As String
    'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile

    StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir

    Loop

End Function

The UDF searched the lists for a specific extension like that

Code: Select all

Sub Test()
    Dim sPath As String
    sPath = ThisWorkbook.Path & "\FolderTest\"
    Dim x
    x = LoopThroughFiles(sPath, ".tiff")
End Sub

How can I add more extensions to get a list of all the desired extensions of files?

[HansV]

You have to create a separate loop for each extension, or use FileSystemObject, but that is more cumbersome.

[YasserKhalil]

The extensions would be three or four only. How can I implement it without looping through each extension ?

[YasserKhalil]

I tried to avoid the point of extensions so this is my final code

Code: Select all

Dim fso As Object, f As Boolean

Sub Search_Files()
    Dim sourcePath As String, targetPath As String, r As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    targetPath = ThisWorkbook.Path & "\Output\"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then sourcePath = fso.GetFolder(.SelectedItems(1)).Path Else Exit Sub
    End With
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(targetPath) Then
            On Error Resume Next
                .DeleteFile targetPath & "\*.*", True
                .DeleteFolder targetPath & "\*.*", True
                RmDir targetPath
            On Error GoTo 0
        End If
        .CreateFolder (targetPath)
    End With
    Columns(2).ClearContents
    For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        f = False
        CopyFiles sourcePath, targetPath, CStr(Cells(r, 1).Value)
        If f = False Then Cells(r, 2).Value = "Not Found"
    Next r
    MsgBox "Done...", 64
End Sub

Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String, ByVal sFileToSearch As String)
    Dim fileInFolder As Object
    For Each fileInFolder In fso.GetFolder(strPath).Files
    If sFileToSearch = fso.GetBaseName(fileInFolder) Then
    fileInFolder.Copy strTarget: f = True: Exit For
    End If
    Next fileInFolder
End Sub

The code is supposed to search for the file names listed in the column A and if found, the file is copied to "Output" folder ..

Can you have a look and review the code for more enhancement? Is the logic will be faster in my case as the source folder has about 30,000 files so I am not sure (I didn't test yet on the original folder)?