Matching partial file names from an excel table and copying all matching files to a subfolder inside the source folder

Question

I'm trying to match using partial file names, then copy all matching files to a subfolder within the source folder.

This is another users pic, but I'm trying to use "TPS" from column D to copy the "TPS report" file into a new folder called "found files" located inside the "document folder" source folder. example

Basically, I've got a list of PO#s and a folder with all those POs saved in it. However, the full file names have a bunch of extraneous data after the PO# so I'd like to just use the PO# at the beginning of the format to match them. (ex: search for 20448 results in the file labeled: 20448 xxxx-xxxxxxxxxx, xxx-xxx, xxxxx-xx)

I found some code, but I'm hoping someone can help me tweak it a bit, as I can't seem to get the code to work past creating the subfolder...

CODE:

Sub SearchFiles()
Dim ws                      As Worksheet
Dim tbl                     As ListObject
Dim cel                     As Range
Dim rootFolder              As String
Dim strNameNewSubFolder     As String
Dim fso                     As FileSystemObject
Dim newFolder               As Folder
Dim fil                     As File
Dim strFilepath             As String
Dim newFilePath             As String

Set fso = New FileSystemObject
Set ws = Worksheets("B")
Set tbl = ws.ListObjects(1)

'Path of the Source folder with files
rootFolder = "C:\Users\sktneer\Documents"

If Not fso.FolderExists(rootFolder) Then
    MsgBox rootFolder & " doesn't exist.", vbExclamation, "Source Folder Not Found!"
    Exit Sub
End If

'files that are found in the Source Folder would be copied to this New Sub-Folder
'Change the name of the Sub-Folder as per your requirement
strNameNewSubFolder = "Found Files"

If Right(rootFolder, 1) <> "/" Then rootFolder = rootFolder & "/"

If Not fso.FolderExists(rootFolder & strNameNewSubFolder) Then
    fso.CreateFolder rootFolder & strNameNewSubFolder
End If

Set newFolder = fso.GetFolder(rootFolder & strNameNewSubFolder)

tbl.DataBodyRange.Columns(4).Interior.ColorIndex = xlNone

For Each cel In tbl.DataBodyRange.Columns(4).Cells
    strFilepath = rootFolder & cel.Value
    newFilePath = newFolder.Path & "/" & cel.Value
    If fso.FileExists(strFilepath) Then
        cel.Interior.Color = vbYellow
        Set fil = fso.GetFile(strFilepath)
        'The following line will copy the file found to the newly created Sub-Folder
        fil.Copy newFilePath
    End If
Next cel
Set fso = Nothing
End Sub

I'm wondering what I would need to add to this code to have it return the correct files using partial file names. Any and all help is massively appreciated.

Thanks in advance!

I'm very new to this, so I've successfully modified the code I found so the directory locations fit my usage. I've searched and found a bunch of code that supposedly uses partial file names to search, but I'm not sure how to integrate it into the current code...

Please be more specific about what you are trying to copy. Are you trying to copy all the files that begin with or contain the numbers in the `Client ID` column? Are you trying to copy all files that start with a number that the user would enter into an input box? — VBasic2008, Aug 18 '23 at 22:32

score 0 · Answer 1 · answered Aug 18 '23 at 22:01

This should work, using Like to check for name matches:

Sub SearchFiles()
    'Path of the Source folder with files, including ending \
    Const ROOT_FOLDER As String = "C:\Users\sktneer\Documents\"
    Const FOUND_FOLDER As String = "Found Files"
    
    Dim cel As range, fso As FileSystemObject
    Dim newFolder As String, strFilepath As String
    Dim newFilePath As String, fldr As Folder, f As File
    Dim col As New Collection, i As Long
    
    Set fso = New FileSystemObject
    
    If Not fso.FolderExists(ROOT_FOLDER) Then
        MsgBox ROOT_FOLDER & " doesn't exist.", vbExclamation, "Source Folder Not Found!"
        Exit Sub
    End If
    Set fldr = fso.GetFolder(ROOT_FOLDER)
    
    newFolder = ROOT_FOLDER & FOUND_FOLDER & "\" 'needs the final "\"
    If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder
    
    'run one loop over the files and collect the files
    For Each f In fldr.Files
        col.Add f
    Next f
    
    With ThisWorkBook.Worksheets("B").ListObjects(1).DataBodyRange.Columns(4)
        .Interior.ColorIndex = xlNone
        For Each cel In .Cells
            For i = col.Count To 1 Step -1 'loop backwards (if removing)
                Set f = col(i)
                If LCase(f.Name) Like LCase(cel.Value) & "*" Then 'case-insensitive match
                    f.Copy newFolder
                    'col.Remove i 'no need to check this file again?
                    cel.Interior.Color = vbYellow
                End If
            Next i
        Next cel
    End With
    
End Sub

score 0 · Answer 2 · answered Aug 19 '23 at 07:44

This code copies files from the given source to the target directory with the FileSystemObject object. Two parameters have to be set within the code.

searchstring is the partial string to be searched in the filenames.
overwrite if set to True overwrites the existing file in the target folder.

The search start from the first position in the filename and match is searched in the whole filename. The search is not case-sensitive.

Sub SearchFiles()
Dim rootFolder              As String
Dim strNameNewSubFolder     As String
Dim ftc                     As Files
Dim fso                     As FileSystemObject
Dim fileit                  As File
Dim strFilepath             As String
Dim newFolder               As String
Dim copycount               As Long
Const searchstring = "20448"
Const overwrite = True

Set fso = New FileSystemObject
copycount = 0
'Path of the Source folder with files
rootFolder = "C:\Users\sktneer\Documents\"

If Not fso.FolderExists(rootFolder) Then
    MsgBox rootFolder & " doesn't exist.", vbExclamation, "Source Folder Not Found!"
    Exit Sub
End If

'files that are found in the Source Folder would be copied to this New Sub-Folder
'Change the name of the Sub-Folder as per your requirement
strNameNewSubFolder = "Found Files\"

If Not fso.FolderExists(rootFolder & strNameNewSubFolder) Then
    fso.CreateFolder rootFolder & strNameNewSubFolder
End If

newFolder = rootFolder & strNameNewSubFolder
Set ftc = fso.GetFolder(rootFolder).Files
For Each fileit In ftc
If InStr(1, fileit.Name, searchstring, 1) <> 0 Then
copycount = copycount + 1
fso.CopyFile rootFolder & fileit.Name, newFolder & fileit.Name, overwrite
End If
Next fileit
Set fso = Nothing
MsgBox copycount & " files are copied." & Space(15), , "Selective File Copy"
End Sub

Matching partial file names from an excel table and copying all matching files to a subfolder inside the source folder

2 Answers2