Excel VBA: Organise Files into Subfolders based on File Type
This video demonstrates using VBA's FileSystemObject to organise files into subfolders by file type. Please also find the featured VBA code, below. https://www.youtube.com/watch?v=wtpUEvMIvD8
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
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" & "\" '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.Type) Then '... create the subfolder for the file type fso.CreateFolder (NewFoldPath & Fle.Type) End If 'Copy the file to the correct subfolder Fle.Copy NewFoldPath & Fle.Type & "\" & Fle.Name Next Fle 'Delete the original folder TheFolder.Delete End If End Sub |
Read More
