Archiving folders that contain subfolders with files that are past a certain date

Question

I am creating a macro that functions as an archiving tool. Basically, the tool has to archive folders that contain subfolders that contain files that meet certain archiving criteria (ex. archive folders where ALL files in subfolders are older than December 4th 2023). The parent folder's last-modified date does not always reflect the date of the most recent file in the subfolder.

I started off by using a recursive function but unfortunately my code pulls out the individual files from the subfolders into the archive location. I need the file structure preserved.

What I want is: Folder A contains subfolder B, which contains Files C and D. Files C and D are older than DATE, so we can archive Folder A and its contents. Folder W contains subfolder X, which contains Files Y and Z; file Z was created after DATE, so the parent folder won't be archived.

Currently, my code archives Files C, D, and Y. Would anyone be able to help me with this issue? I've been trying to get this for over a week.

I know this would be easier using PowerShell, however I am only allowed to use VBA.

Answer 1

Archive Old Subfolders Using the FileSystemObject Object

• It is assumed that the source folder contains subfolders that contain only files (no folders).
• Each subfolder is moved to the destination folder if all its files are older than a given date.

Sub ArchiveFolders()

    Const SRC_FOLDER_PATH As String = "C:\SourcePath"
    Const DST_FOLDER_PATH As String = "C:\DestinationPath"
    Const BEFORE_DATE_STRING As String = "2023-12-4"
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(SRC_FOLDER_PATH)
    
    Dim BeforeDate As Date: BeforeDate = DateValue(BEFORE_DATE_STRING)
    
    Dim fsoSubfolder As Object, fsoFile As Object
    Dim IsOlderFileFound As Boolean, IsNewerFileFound As Boolean
    
    For Each fsoSubfolder In fsoFolder.SubFolders
        For Each fsoFile In fsoSubfolder.Files
            '.DateCreated', '.DateLastAccessed', or '.DateLastModified'
            If fsoFile.DateLastModified < BeforeDate Then
                IsOlderFileFound = True
            Else
                IsNewerFileFound = True
                Exit For
            End If
        Next fsoFile
        If IsNewerFileFound Then ' newer file found; do nothing
            IsNewerFileFound = False ' reset
        Else ' no newer file was found
            If IsOlderFileFound Then ' all files are older
                fso.MoveFolder fsoSubfolder.Path, _
                    fso.BuildPath(DST_FOLDER_PATH, fsoSubfolder.Name)
            'Else ' no file found; do nothing!?
            End If
        End If
        IsOlderFileFound = False ' reset whether a newer file was found or not
    Next fsoSubfolder
            
    MsgBox "Folders archived.", vbInformation
    
End Sub