Loop Through All Folders and All its Subfolders VBA

Question

i know the question was asked many times before, i have checked the previous suggestions but i couldn't make my code run.

So, i have a folder called "Report" which contains multiple folders as well. These folders contains .xlsx and .zip files.

Each file contains also a folder called "2016" and under it 12 folders "January", "February",..., "December".

Here is an example of one Subfolder

What i want to do is, to loop through all these subFolders and move the .xlsx and .zip files to the monthly folder based on createdDate.

For example, all .xlsx and .zip in a location created in November they will be moved to the folder "November" in "2016" in the same location.

I created this macro but it's time consuming because everytime i need to change the path of each subfloder and run it for each subFolder.

Sub Move_Files_To_Folder()

Dim Fso As Object
Dim FromPath As String
Dim ToPath As String
Dim FileInFromFolder As Object

'Change Path
FromPath = "C:\Report\Shipment\"
ToPath = "C:\Report\Shipment\2016\"

Set Fso = CreateObject("scripting.filesystemobject")

For Each FileInFromFolder In Fso.GetFolder(FromPath).Files

'Change month and year
If (Month(FileInFromFolder.DateCreated)) = 11 And (year(FileInFromFolder.DateCreated)) = 2016 _
And (InStr(1, FileInFromFolder.name, ".xlsx") Or InStr(1, FileInFromFolder.name, ".zip")) Then
FileInFromFolder.Move (ToPath & MonthName(Month(FileInFromFolder.DateCreated)) & "\")
End If

Next FileInFromFolder

End Sub

I want to automate my macro so that it will work on all the subfolders Not one by one and changing the path everytime. Any suggestions please ? Thank you very much.

Answer 1

Unlike @luke_t and @Lowpar, I don't think that recursive loop, looking in all subfolders and files is right answer here, because when you get to the bottom folder (i.e. C:\Report\Shipment\2016\May\) you will get and move files that are already in right place.

Thanks to fact that you have fixed structure of folders, you can just loop through every .xlsx and .zip file in every subfolder of main folder (C:\Report\).

Sub Move_Files_To_Folder()

Dim Fso As Object, objFolder As Object, objSubFolder As Object
Dim FromPath As String
Dim FileInFolder As Object

FromPath = "C:\Report\"
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(FromPath)

For Each objSubFolder In objFolder.subfolders
    For Each FileInFolder In objSubFolder.Files

        If InStr(1, FileInFolder.Name, ".xlsx") Or InStr(1, FileInFolder.Name, ".zip") Then
            FileInFolder.Move (objSubFolder.path & "\2016\" & MonthName(Month(FileInFolder.DateCreated)) & "\")
        End If

    Next FileInFolder
Next objSubFolder

End Sub

However, if structure of folders would be dynamic, the approach that proposed @luke_t would be more appropriate.

Answer 2

I would suggest using a recursive function to get to the bottom level of the folder structure.

The below function will iterate through all sub-folders, from the folder supplied.

Once the function has reached the bottom level of the folder structure, it will then commence to iterate through each file, moving if required (providing you input the code to perform this task, where I have placed a comment in the below example).

You will need to enable the Microsoft Scripting Runtime reference (VBE -> Tools -> References)

Option Explicit

Public Sub move_documents()

    Dim fSystem As Scripting.FileSystemObject
    Dim fp As String

    Set fSystem = New Scripting.FileSystemObject
    fp = "C:\xyz" ' Enter your folder start location

    find_folders fSystem.GetFolder(fp)

End Sub

Private Function find_folders(ByVal fldr As Folder)

    Dim sf As Folder

    For Each sf In fldr.SubFolders
        find_folders sf, ws
    Next

    ' Enter function or code to move each file in a folder here.

End Function