Using partial file names in an excel table to match and copy files to a subfolder

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.

Basically, I've got a list of PO#s and a folder with all those POs saved in it, but the full file names have a bunch of extraneous data after the PO# so I'd like to just use those to match them. I found some code from another user (@Subodh_Tiwari_sktneer), but I'm hoping someone can help me tweak it a bit, as I can't seem to get the code to work...

I've gotten it to create the subfolder in the source folder, but I would like to have the program search for partial file names instead of whole names (ex: search for 20448 results in the file labeled: 20448 xxxx-xxxxxxxxxx, xxx-xxx, xxxxx-xx)

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!