Move to folder based on file name

I have a task at work and I’m not sure how to do what I want to do. I mail merge tons of letters and must file them into respective folders.

I can move files fine using

Sub MOVEFILES()

    Dim strFolderA As String
    Dim strFolderB As String
    Dim strFile As String
    Dim Cnt As Long
    Dim test As String
    
    test = 9
    '//Change the path to the source folder, accordingly
    strFolderA = "C:\Users\dtrowbri\Desktop\Test2\"
    
    '//Change the path to the destination folder, accordingly
    strFolderB = "C:\Users\dtrowbri\Desktop\Test\"
    
    'If Right(strFolderA, 1) <> "\" Then strFolderA = strFolderA & "\"
    'If Right(strFolderB, 1) <> "\" Then strFolderB = strFolderB & "\"
    
    '//To filter for .xlsx files, change "*.*" to "*.xlsx"
    strFile = Dir(strFolderA & "*.*")
    
    Do While Len(strFile) > 0
        
        Cnt = Cnt + 1
        Name strFolderA & strFile As strFolderB & strFile
        strFile = Dir
    Loop
    
    MsgBox Cnt & " file(s) have been transfered to " & strFolderB, vbInformation
        
End Sub

Now here’s the juicy part.

I have files named 2 ways

AB_######_name.pdf ‘where ###### is unique and
ABC_######_name.pdf ‘ where again ###### is unique


Our folder system is like this:
C:\AB_######_name\Correspondence\ ‘THIS IS THE TARGET FOLDER FOR THE LETTER or
C:\ABC_######_name\Correspondence\ ‘THIS IS THE TARGET FOLDER FOR THE LETTER



The ###### in the Folder Name would be correspond to the PDF filename.

Now how do I go ahead and move the filename to the correct folders. Sometimes the correspondence folder is not created, so I have to create it manually.

I'm thinking this should work. The function MakeFolders is from my free code site, it will create the folder(s) as needed.

Option Explicit

Sub MOVEFILES()
'Jerry Beaucaire  www.ExcelForum.com    1/22/2014
Dim fPATH As String, fNAME As String, fTYPE As String, fDEST As String
Dim Cnt As Long
    
fPATH = "C:\Path\To\Source\Files\"          'remember the final \ in this string
fTYPE = ".PDF"                              'extension, filetype to find and move

fNAME = Dir(fPATH & "*" & fTYPE)            'get first filename
        
Do While Len(fNAME) > 0
    Cnt = Cnt + 1                           'increment counter
    fDEST = "C:\" & Replace(fNAME, fTYPE, "") & "\Correspondence\"      'create destination string
    MakeFolders (fDEST)                     'create folders if needed
    
    Name fPATH & fNAME As fDEST & fNAME     'move the file
    fNAME = Dir                             'get next filename
Loop                                        'lather, rinse, repeat

MsgBox Cnt & " file(s) have been transfered to their respective correspondence folders", vbInformation
        
End Sub


Function MakeFolders(MyStr As String)
'Author:    Jerry Beaucaire
'Date:      7/14/2010
'Summary:   Create directories and subdirectories based on the text strings fed to the function
'           This version is to be called by other macros
'           10/19/2010 - International compliant
Dim MyArr As Variant, pNum As Long
Dim pBuf As String, Delim As String

    On Error Resume Next
    Delim = Application.PathSeparator

    MyArr = Split(MyStr, Delim)
    pBuf = MyArr(LBound(MyArr)) & Delim
    For pNum = LBound(MyArr) + 1 To UBound(MyArr)
        pBuf = pBuf & MyArr(pNum) & Delim
        MkDir pBuf
    Next pNum

End Function