存档包含子文件夹（其中包含超过特定日期的文件）的文件夹

Question

我正在创建一个用作存档工具的宏。基本上，该工具必须归档包含子文件夹的文件夹，这些子文件夹包含满足特定归档标准的文件（例如，子文件夹中的所有文件都早于 2023 年 12 月 4 日的归档文件夹）。父文件夹的上次修改日期并不总是反映子文件夹中最新文件的日期。

我首先使用递归函数，但不幸的是我的代码将各个文件从子文件夹中提取到存档位置。我需要保留文件结构。

我想要的是：文件夹A包含子文件夹B，子文件夹B包含文件C和D。文件C和D早于DATE，因此我们可以存档文件夹A及其内容。文件夹W包含子文件夹X，子文件夹X包含文件Y和Z；文件 Z 是在 DATE 之后创建的，因此不会存档父文件夹。

目前，我的代码存档文件 C、D 和 Y。有人能帮助我解决这个问题吗？我已经尝试了一个多星期了。

我知道使用 PowerShell 会更容易，但我只允许使用 VBA。

Answer 1

存档旧子文件夹

• 假设源文件夹包含仅包含文件（无文件夹）的子文件夹。
• 对于每个子文件夹，如果其所有文件都早于给定日期，则该子文件夹将移动到目标文件夹。

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