VBA Move files to subfolders based on filename

[Khsii]

Hi everyone,

I am new to this forum even though I have been using it for years. My turn to ask for your help as I couldn't find a solution to my problem so far.

Here is my issue:
I have several files with a given name in a same folder, let's say drive D:
Ex:
D:\AAAA.xls
D:\BBBB.xls
D:\CCCC.xls

I want to have a macro that would allow me to move each .xls file to its designated subfolder (same name). Issue ? The different sub-folders can be located in a different level of sub-folders.
Ex:
Folder AAAA can be located in D:\Folder1\SubFolder1\Subfolder2\AAAA
Folder BBBB can be located in D:\Folder1\SubFolder1\Subfolder2\AAAA\BBBB
Folder CCCC can be located in D:\Folder1\SubFolder2\Subfolder3\CCCC

The logic of the Macro would be:
For each file in a specific folder (D:\ or current folder of the workbook), look for each subfolder in this folder, and when a subfolder with the same name (or at least the n first characters) is found, move this file to this subfolder. Continue with next file and if their is an error, still continue the process until the end and Prompt the Msgbox at the end of the macro:
"The following folders don't exist :
- AAAA
- BBBB
- etc."

NB: each subfolder have already been created and have a unique name.

Most of the time, google is my best friend and I can adapt a macro to fit my requirements, but for this case, I could only find:
- How to move files from a folder to 1 destination sub-folder
- How to move files from a folder to subfolders with the same name (but the macro will not go deeper than the first level of subfolder)
- How to create folders from files and move those files to these folders

I'm sorry if the solution to my problem already exist, but I couldn't find it.

Thanks in advance !

 

[John_w]

Do you still need help with this? Look for VBA code which calls a recursive FileSystemObject routine to find the required matching folder name.

 

[Khsii]

Hi,

Yes, still need a help !

Sub MoveFiles()    
    Dim objFSO As Scripting.FileSystemObject
    Dim objTopFolder As Scripting.Folder
    Dim strTopFolderName As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .ButtonName = "Select Folder"
        If .Show = 0 Then Exit Sub
        strTopFolderName = .SelectedItems(1)
    End With
        
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    Set objTopFolder = objFSO.GetFolder(strTopFolderName)
    
    Call RecursiveMove(objTopFolder, True)
    
End Sub


Sub RecursiveMove(objFolder As Scripting.Folder, _
    IncludeSubFolders As Boolean)


    Dim objFile As Scripting.File
    Dim objSubFolder As Scripting.Folder
    
    For Each objFile In objTopFolder.Files
    If objFile.Name = "*.tif" Then
[COLOR=#008000]'This is where I want to say, "For each file in the parent folder that has the same name as a sub-folder, then move to this subfolder". 
But I don't know how to as .MoveFile need a specific sourcefolder and destination folder...[/COLOR]
    Next objFile
    
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
                Call RecursiveMove(objSubFolder, True)
            End If
        Next objSubFolder
    End If
    
    End With
End Sub

 

[John_w]

Here's how I would do it. Note though, that the following 2 bolded statements are contradictory:

.... Prompt the Msgbox at the end of the macro:
"The following folders don't exist :
- AAAA
- BBBB
- etc."

NB: each subfolder have already been created and have a unique name.

If the destination folders (AAAA, BBBB, etc.) have already been created then there is no need for the MsgBox message at the end of macro. However the following code checks whether each folder exists and if not displays the message at the end.

Public Sub Move_Files()

    Dim sourceFolder As String, fileName As String
    Dim destinationFolder As String, foundDestinationFolder As String
    Dim missingFolders As String
    
    sourceFolder = "D:\"
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    
    'Loop through *.xls files in source folder
    
    missingFolders = ""
    fileName = Dir(sourceFolder & "*.xls")
    While fileName <> vbNullString
        If Right(fileName, 4) = ".xls" Then
            destinationFolder = Left(fileName, InStrRev(fileName, ".") - 1)
            foundDestinationFolder = Find_Subfolder(sourceFolder, destinationFolder)
            If foundDestinationFolder <> "" Then
                Name sourceFolder & fileName As foundDestinationFolder & fileName
            Else
                missingFolders = missingFolders & vbCrLf & destinationFolder
            End If
        End If
        fileName = Dir
    Wend
    
    If missingFolders = "" Then
        MsgBox "All subfolders exist.  All files moved to their respective destination folder"
    Else
        MsgBox "The following subfolders don't exist:" & vbCrLf & _
                missingFolders
    End If

End Sub



Private Function Find_Subfolder(folderPath As String, subfolderName As String) As String

    Static FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object
    
    'Traverse subfolders from a folder path and return when matching folder name found
    
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set FSfolder = FSO.GetFolder(folderPath)
     
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.subfolders
        If UCase(FSsubfolder.Name) = UCase(subfolderName) Then
            Find_Subfolder = FSsubfolder.Path & "\"
        Else
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, subfolderName)
        End If
        If Find_Subfolder <> "" Then Exit For
    Next
    
End Function

If necessary, edit the "sourceFolder = ..." line to the full path of the folder containing the *.xls files, or incorporate your folder picker code.

 

[Khsii]

Wow, it works like a charm !

Thank you John for your time and for this code ! You just saved me days of research for the macro, and countless days of manual cut/paste !!!

 

[taimoor07]

Here's how I would do it. Note though, that the following 2 bolded statements are contradictory:

If the destination folders (AAAA, BBBB, etc.) have already been created then there is no need for the MsgBox message at the end of macro. However the following code checks whether each folder exists and if not displays the message at the end.

Public Sub Move_Files()

    Dim sourceFolder As String, fileName As String
    Dim destinationFolder As String, foundDestinationFolder As String
    Dim missingFolders As String
   
    sourceFolder = "D:\"
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
   
    'Loop through *.xls files in source folder
   
    missingFolders = ""
    fileName = Dir(sourceFolder & "*.xls")
    While fileName <> vbNullString
        If Right(fileName, 4) = ".xls" Then
            destinationFolder = Left(fileName, InStrRev(fileName, ".") - 1)
            foundDestinationFolder = Find_Subfolder(sourceFolder, destinationFolder)
            If foundDestinationFolder <> "" Then
                Name sourceFolder & fileName As foundDestinationFolder & fileName
            Else
                missingFolders = missingFolders & vbCrLf & destinationFolder
            End If
        End If
        fileName = Dir
    Wend
   
    If missingFolders = "" Then
        MsgBox "All subfolders exist.  All files moved to their respective destination folder"
    Else
        MsgBox "The following subfolders don't exist:" & vbCrLf & _
                missingFolders
    End If

End Sub



Private Function Find_Subfolder(folderPath As String, subfolderName As String) As String

    Static FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object
   
    'Traverse subfolders from a folder path and return when matching folder name found
   
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
   
    Set FSfolder = FSO.GetFolder(folderPath)
    
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.subfolders
        If UCase(FSsubfolder.Name) = UCase(subfolderName) Then
            Find_Subfolder = FSsubfolder.Path & "\"
        Else
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, subfolderName)
        End If
        If Find_Subfolder <> "" Then Exit For
    Next
   
End Function

If necessary, edit the "sourceFolder = ..." line to the full path of the folder containing the *.xls files, or incorporate your folder picker code.

Hi John. First of all Thank you for your help to the community. Can you please check my recent post i have almost the same file but i am encountering an error. Your help will be highly appreciated Sir. Thank you