How to copy files with similar name into folders?

Question

I am creating an archiving system where I need to sort files into folders.
I create the folders automatically by mentioning the names of folder in an Excel sheet.

Now I need to copy the files with similar names in that respective folder.
E.g. A folder is created with the name "Ashley Davidson". All the files which are in one source folder and whose file name starts with Ashley Davidson should be copied to this folder.

There will be more than 500 folders and more than 10,000 files to be copied in these folders every week.

The code below creates the folders.
How can I copy the files based on similar name to these folders?

Important
The names of folders will be constant.
The start of the names of files will be similar but users add other words like date, age, sheet 1, sheet 2 etc., therefore List of Partial name concept will probably work here.

Examples of folder names

Example of file names

Code to create folders:

Sub MakeFolders()

    Dim sh As Worksheet, lastR As Long, arr, i As Long, rootPath As String
    
    Set sh = ActiveSheet
    lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
    arr = sh.Range("A2:A" & lastR).Value2
    rootPath = ThisWorkbook.Path & "\"

    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" And noIllegalChars(CStr(arr(i, 1))) Then
            If Dir(rootPath & arr(i, 1), vbDirectory) = "" Then
                MkDir rootPath & arr(i, 1)
            End If
        Else
            MsgBox "Illegals characters or empty cell (" & sh.Range("A" & i + 1).Address & ")..."
        End If
    Next i

End Sub

Function noIllegalChars(x As String) As Boolean
   Const illCh As String = "*[\/\\"":\*?]*"
   If Not x Like illCh Then noIllegalChars = True
End Function

Answer 1

My code works from having the new Folders in the same folder as the workbook you've created said folders from (as it is in your code) and the files to be copied were in a seperate folder in the same path as your workbook; I found that easier to work with since then the only files in that folder are files to be copied, not extra folders within.

Sub copyFilesToFolder()
    Dim lRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim ccell As Range
    Dim fsO As Object, oFolder As Object, oFile As Object
    Dim pathFiles As String, sFolderPath As String, sSource As String, sDestination As String
    
    Set wb = ActiveWorkbook
    Set ws = wb.ActiveWorksheet
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    pathFiles = "Q:\WHERE YOUR ORIGINAL WORKBOOK IS\Test\" 'could be gotten from wb technically
    
    Set fsO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fsO.GetFolder(pathFiles)
    For Each oFile In oFolder.Files 'go through all the files
        For Each ccell In Range("A2:A" & lRow).Cells 'go through all the folder-names
            'Debug.Print ccell.Value2
            'Debug.Print oFile.Name
            If InStr(oFile.Name, ccell.Value2) > 0 Then 'if folder name is in file name
                sFolderPath = wb.Path & "\" & ccell.Value2 & "\"
                If Dir(sFolderPath, vbDirectory) <> "" Then 'if Folder exists
                    sDestination = sFolderPath & oFile.Name
                    If Dir(sDestination) = "" Then 'file doesn't exist yet
                        sSource = pathFiles & oFile.Name
                        'Debug.Print sSource
                        'Debug.Print sDestination
                        Call fsO.CopyFile(pathFiles & oFile.Name, sFolderPath & oFile.Name)
                        GoTo Skip
                    End If
                Else
                    MsgBox ("Folder " & ccell.Value2 & " doesn't exist yet")
                End If
            End If
        Next ccell
Skip:
    Next oFile
    
End Sub

Hope this helps :)

Answer 2

You did not answer the clarification question and I need to leave my office. The next code assumes that all files exist in a common folder and they should be moved in the folder exactly named as the string in column A:A of the active sheet. It is able to move or copy the file, according to the line you should uncomment:

Sub moveMatchedFilesInAppropriateFolders()
    Dim sh As Worksheet, lastR As Long, filesPath As String, fileName As String, foldersRoot As String, folderPath As String
    Dim arr, boolNotFound As Boolean, i As Long
    
    Set sh = ActiveSheet
    lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
    
    arr = sh.Range("A2:A" & lastR).Value2
    foldersRoot = ThisWorkbook.Path & "\" 'use here the root folder for folders
    filesPath = "your files to be processed folder"   'use here the path where the files can be found
    Set fso = CreateObject("Scripting.FileSystemObject") 'to check if file exists

    For i = 1 To UBound(arr)
        boolNotFound = False
        If Dir(foldersRoot & arr(i, 1), vbDirectory) <> "" Then
            folderPath = foldersRoot & arr(i, 1) & "\"
        Else
            MsgBox arr(i, 1) & " folder could not be found!" & vbCrLf & _
                           "Please, note and correct it after copying the matching ones and run the code again!"
            boolNotFound = True
        End If
        If Not boolNotFound Then
                fileName = Dir(filesPath & arr(i, 1) & "*.*")
                
                Do While fileName <> ""
                If Not fso.FileExists(folderPath & fileName) Then 'move/copy only if it does not exist in destination fld
                    'uncomment the way you need (moving or copying):
                    'Name filesPath & fileName As folderPath & fileName    'the file is moved
                    'FileCopy filesPath & fileName, folderPath & fileName   'the file is copied
                End If
                fileName = Dir
            Loop
         End If
    Next i
End Sub

Not tested, but it should work.

If you need something else, please better answer my last clarifications question.

Besides all that, I think it would be good to place a marker in B:B column, for not found folders, if any. In this way, the code can be adapted that at the next run to only run the ones having the marker (and delete it, if the string has been corrected and the folder has been found).