VBA folder maker from files name

[Pheonix2332]

hello all,

I am pretty new to VBA coding but have been "digging" around in a few of my works report templates we use and have been able to "fix" it being a better term to allow me to create multiple case files for cases I have worked with minimal effort based on a mail merge vba I remembered from a previous job, however I have hit a small conundrum. I am able to make the folders for each case individually and now I have also learned how to make them in VBA from the same database used for the mail merge .

a brief example would be the case ID 180045 and the case files being headersheet 180045, stage 1 letter for 180045 ect.

the problem I am having now is I am unable to automatically move the files into the designated folders, ideally I would like the folders to be made at the time the mail merge is being done but due to not being able get this code right now as outside of office is a pain but can get and provide if needed, however I have found some code on her that might help - its from a youtube video and has helped make the folders but now they have the file extension - .doc, .pdf etc here is the code with very minor changes

Option Explicit

Sub OrganiseFilesbyFileType()

'Create an instance of the FileSystemObject
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
'Declare a variable for the folder we will loop in
Dim folderPath As String
'Declare a variable for the files we will loop through
Dim Fle As Scripting.File
'Prompt the user for the folder they want to organise
Dim FoldPathPrompt As FileDialog
Set FoldPathPrompt = Application.FileDialog(msoFileDialogFolderPicker)
With FoldPathPrompt
    .Title = "Select the folder you want to organise files in"
    'If OK is selected, assign the folder path to the FolderPath variable
    If .Show = -1 Then folderPath = .SelectedItems(1)
End With

'If a folder path has been specified...
If folderPath <> "" Then

'Declare a variable to store the folder's parent folder's path
    Dim ParentPath As String
    ParentPath = FSO.GetParentFolderName(folderPath)
    
'Declare a variable to store the folder
    Dim TheFolder As Scripting.Folder
    Set TheFolder = FSO.GetFolder(folderPath)
    
'Declare a variable to store the folder's name
    Dim FolderName As String
    FolderName = FSO.GetFolder(folderPath).Name
    
'Declare variable to store the new folder path
    Dim NewFoldPath As String
    NewFoldPath = ParentPath & "\" & FolderName & " - Organised" & "\"
     On Error Resume Next
     
'Create a new folder
    FSO.CreateFolder NewFoldPath
    
    
'Loop through each file in the folder that the user has specified
    
    For Each Fle In TheFolder.Files
        'If the subfolder for the file type does not already exist...
        If Not FSO.FolderExists(NewFoldPath & Fle.Name) Then
            '... create the subfolder for the file type
            FSO.CreateFolder (NewFoldPath & Fle.Name)
        End If
        'Copy the file to the correct subfolder
        Fle.Copy NewFoldPath & Fle.Name & "\" & Fle.Name
    
    Next Fle
'Delete the original folder
    'TheFolder.Delete

End If


End Sub

can anybody please have a look and advise what I need to change to just have the folders as 180045 etc ? cheers.

I also came across this code on her for something similar but I might be missing something as its not moving files unless the folders name is an exact match some documents are named different but the case ID on each document for each case is always present either at the start or end of the letter or PDF report pending on who has typed it up is it possible to have the code just look for a sequence of numbers no more than 6 digits and ignore the words ?

the file names are Headersheet 123456,
file for this would be file :- 123456
other documents such as emails etc will have the reference in the name of them such as
stage 1 letter for 123456.

I have the bottom code to work somewhat if the files are already there but only if the files are an exact match. any help will be appreciated

Public Sub Move_Files_To_Matching_Folder()
    
    Dim sourceFolder As String, destMainFolder As String, destSubfolder As String
    Dim FSO As Object
    Dim FSfile As Object
    Dim FSsourceFolder As Object
    
    sourceFolder = Environ$("USERPROFILE") & "\OneDrive\Desktop\test\"
    destMainFolder = Environ$("USERPROFILE") & "\OneDrive\Desktop\test\moved\"

    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    If Right(destMainFolder, 1) <> "\" Then destMainFolder = destMainFolder & "\"

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set FSsourceFolder = FSO.GetFolder(sourceFolder)
    For Each FSfile In FSsourceFolder.Files
        destSubfolder = destMainFolder & Left(FSfile.Name, InStrRev(FSfile.Name, ".") - 1) & "\"
        If FSO.FolderExists(destSubfolder) Then
            If FSO.FileExists(destSubfolder & FSfile.Name) Then FSO.DeleteFile destSubfolder & FSfile.Name, True
            FSfile.Move destSubfolder
        End If
    Next

End Sub