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
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