Automatically Create Folders By Extension

Question

I have a code that is working and is organizing files by extension. However, it works in only one folder at this time.

Suppose in a parent folder I have 500 subfolders and in each subfolder, there are files with different extensions (e.g. XML, PDF, Word, text, etc). Currently, I need to select each subfolder one at a time and move files into folders by extension via the below code.

However, I need a method where when I select a parent directory, the code should read each subfolder and in each subfolder create folders by extension and move the files to it.

Option Explicit

Sub OrganiseFilesbyFileType()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    Dim Folderpath As String
    Dim Fle As Scripting.File
    
    Dim FoldpathPrompt As FileDialog
    Set FoldpathPrompt = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FoldpathPrompt
        .Title = "Select the folder you want to organise files in"
        If .Show = -1 Then Folderpath = .SelectedItems(1)
    End With
    
    If Folderpath <> "" Then
        
        Dim ParentPath As String
        ParentPath = fso.GetParentFolderName(Folderpath)
            
        Dim FolderName As String
        FolderName = fso.GetFolder(Folderpath).Name
        
        Dim NewFoldPath As String
        NewFoldPath = ParentPath & "\" & FolderName & " - Organized" & "\"
        
        Dim TheFolder As Scripting.Folder
        Set TheFolder = fso.GetFolder(Folderpath)
        
        fso.CreateFolder NewFoldPath
        
        For Each Fle In TheFolder.Files
            If Not fso.FolderExists(NewFoldPath & Fle.Type) Then
                fso.CreateFolder (NewFoldPath & Fle.Type)
            End If
            Fle.Copy NewFoldPath & Fle.Type & "\" & Fle.Name
        Next Fle
        
        TheFolder.Delete
    
    End If

End Sub

Answer 1

Organize Files By File Type

Main

Sub OrganizeFilesByFileType()

    Const iFolderPath As String = "E:\2022" ' adjust!!!
    Const Title As String = "Select the folder you want to organize files in"
    
    Dim FolderPath As String: FolderPath = PickFolder(iFolderPath, Title)
    If Len(FolderPath) = 0 Then Exit Sub
    
    Dim FolderPaths As Collection
    Set FolderPaths = CollSubfolderPaths(FolderPath)
    
    MoveFilesToTypeFolders FolderPaths

End Sub

Folder Picker

Function PickFolder( _
    Optional ByVal InitialFolderPath As String = "", _
    Optional ByVal DialogTitle As String = "Browse", _
    Optional ByVal DialogButtonName As String = "OK", _
    Optional ByVal ShowCancelMessage As Boolean = True) _
As String
    
    Dim FolderPath As String, IsFolderPicked As Boolean
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = DialogTitle
        .ButtonName = DialogButtonName
        Dim pSep As String: pSep = Application.PathSeparator
        If Len(InitialFolderPath) > 0 Then
            FolderPath = InitialFolderPath
            If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
            .InitialFileName = FolderPath
        End If
        If .Show Then
            FolderPath = .SelectedItems(1)
            If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
            IsFolderPicked = True
        End If
    End With
    
    If IsFolderPicked Then PickFolder = FolderPath: Exit Function
        
    If ShowCancelMessage Then
        MsgBox "Dialog canceled.", vbExclamation, "Pick Folder"
    End If

End Function

Subfolder Paths To Collection

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the paths of a folder ('FolderPath')
'               and all of its subfolders in a collection.
' Remarks:      Check it only against 'Nothing' (its count cannot be 0).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CollSubfolderPaths( _
    ByVal FolderPath As String, _
    Optional ByVal IncludeFolderPath As Boolean = True) _
As Collection
    Const ProcName As String = "CollSubFolderPaths"
    On Error GoTo ClearError
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(FolderPath) Then Exit Function
    
    Dim collPaths As Collection: Set collPaths = New Collection
    
    Dim collQueue As Collection: Set collQueue = New Collection
    collQueue.Add fso.GetFolder(FolderPath)
    
    Dim fsoFolder As Object
    Dim fsoSubfolder As Object

    Do Until collQueue.Count = 0
        Set fsoFolder = collQueue(1)
        collQueue.Remove 1 ' dequeue!
        collPaths.Add fsoFolder.Path
        For Each fsoSubfolder In fsoFolder.SubFolders
            collQueue.Add fsoSubfolder ' enqueue!
        Next fsoSubfolder
    Loop
      
    If Not IncludeFolderPath Then
        If collPaths.Count = 1 Then Exit Function
        collPaths.Remove 1
    End If
    
    Set CollSubfolderPaths = collPaths

ProcExit:
    Exit Function
ClearError:
    Debug.Print "@" & ProcName & "@ Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

Move Files To Type Folders

Sub MoveFilesToTypeFolders( _
        ByVal FolderPaths As Collection, _
        Optional ByVal ShowMessage As Boolean = True)
    Const PROC_TITLE As String = "Move Files To Type Folders"
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Keys: Type Folder Paths (New), Items: True or False i.e. exists or not
    Dim foDict As Object: Set foDict = CreateObject("Scripting.Dictionary")
    foDict.CompareMode = vbTextCompare
    
    ' Keys: File Paths (Old), Items: Type File Paths (New)
    Dim fiDict As Object: Set fiDict = CreateObject("Scripting.Dictionary")
    fiDict.CompareMode = vbTextCompare
    
    Dim Item, fsoFolder As Object, fsoFile As Object
    Dim FolderName As String, FileType As String, TypePath As String
    
    For Each Item In FolderPaths
        Set fsoFolder = fso.GetFolder(Item)
        FolderName = fsoFolder.Name
        For Each fsoFile In fsoFolder.Files
            FileType = fsoFile.Type
            If StrComp(FolderName, FileType, vbTextCompare) <> 0 Then
                TypePath = fso.BuildPath(Item, FileType)
                If Not foDict.Exists(TypePath) Then
                    foDict(TypePath) = fso.FolderExists(TypePath)
                End If
                fiDict(fsoFile.Path) = fso.BuildPath(TypePath, fsoFile.Name)
            'Else ' the file is already in its type folder; do nothing
            End If
        Next fsoFile
    Next Item
    
    ' Create the folders.
    For Each Item In foDict.Keys
        If Not foDict(Item) Then fso.CreateFolder Item
    Next Item

    ' Move the files.
    For Each Item In fiDict.Keys
        fso.MoveFile Item, fiDict(Item)
    Next Item

    If ShowMessage Then
        If fiDict.Count > 0 Then
            MsgBox "Files moved to type folders.", vbInformation, PROC_TITLE
        Else
            MsgBox "No files found.", vbExclamation, PROC_TITLE
        End If
    End If

End Sub

Answer 2

You can use a recursive function, example:

Option Explicit

Sub OrganiseFilesbyFileType()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    Dim Folderpath As String
    Dim Fle As Scripting.File
    
    Dim FoldpathPrompt As FileDialog
    Set FoldpathPrompt = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FoldpathPrompt
        .Title = "Select the folder you want to organise files in"
        If .Show = -1 Then Folderpath = .SelectedItems(1)
    End With
    
    If Folderpath <> "" Then
        
        Dim ParentPath As String
        ParentPath = fso.GetParentFolderName(Folderpath)
            
        Dim FolderName As String
        FolderName = fso.GetFolder(Folderpath).Name
        
        Dim NewFoldPath As String
        NewFoldPath = ParentPath & "\" & FolderName & " - Organized" & "\"
        
        Dim TheFolder As Scripting.Folder
        Set TheFolder = fso.GetFolder(Folderpath)
        
        fso.CreateFolder NewFoldPath
        
        Call OrganiseFilesbyFileTypeSubfolders(fso, NewFoldPath, TheFolder)
        
        TheFolder.Delete
    
    End If

End Sub

Sub OrganiseFilesbyFileTypeSubfolders(ByVal pFso As Object, ByVal pNewFoldPath As String, ByVal pFsoSubfolder As Object)
    Dim Fle As Object
    Dim NewFoldPath As String
    
    For Each Fle In pFsoSubfolder.Files
        If Not pFso.FolderExists(pNewFoldPath & Fle.Type) Then
            pFso.CreateFolder (pNewFoldPath & Fle.Type)
        End If
        Fle.Copy pNewFoldPath & Fle.Type & "\" & Fle.Name
    Next Fle
    Dim subfolder As Object
    For Each subfolder In pFsoSubfolder.SubFolders
        NewFoldPath = pNewFoldPath & subfolder.Name & "\"
        pFso.CreateFolder NewFoldPath
        Call OrganiseFilesbyFileTypeSubfolders(pFso, NewFoldPath, subfolder)
    Next subfolder
End Sub