VBA归档工具开发求助：需按子文件夹文件日期归档并保留目录结构

针对你需要批量归档所有子文件均满足日期条件的父文件夹的需求，以下是修正后的实现逻辑和代码，核心是先验证父文件夹下所有文件是否达标，再整体复制保留结构：

核心逻辑 #

1. 递归遍历父文件夹下的所有文件（含各级子文件夹），确认全部文件的修改日期早于指定归档日期
2. 若验证通过，将整个父文件夹（包含完整子目录结构）复制到归档路径；若有任何一个文件不达标，则跳过该父文件夹

完整VBA代码 #

Option Explicit

' 主归档函数：遍历指定根目录下的所有一级父文件夹，判断是否符合归档条件
Sub ArchiveQualifiedFolders()
    Dim sourceRootPath As String
    Dim archiveRootPath As String
    Dim archiveDate As Date
    Dim fso As Object
    Dim sourceFolder As Object
    Dim subFolder As Object
    
    ' 配置参数
    sourceRootPath = "C:\YourSourceRoot" ' 存放待检查父文件夹的根目录
    archiveRootPath = "C:\YourArchiveRoot" ' 归档目标根目录
    archiveDate = #12/4/2023# ' 归档日期阈值（所有文件需早于该日期）
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 检查源目录是否存在
    If Not fso.FolderExists(sourceRootPath) Then
        MsgBox "源目录不存在，请检查路径", vbExclamation
        Exit Sub
    End If
    
    ' 创建归档目录（如果不存在）
    If Not fso.FolderExists(archiveRootPath) Then
        fso.CreateFolder archiveRootPath
    End If
    
    Set sourceFolder = fso.GetFolder(sourceRootPath)
    
    ' 遍历每个一级父文件夹
    For Each subFolder In sourceFolder.SubFolders
        ' 检查当前父文件夹下所有文件是否都符合归档日期
        If IsFolderQualified(subFolder, archiveDate) Then
            ' 复制整个文件夹到归档目录，保留结构
            fso.CopyFolder subFolder.Path, archiveRootPath & "\" & subFolder.Name & "\", True
            Debug.Print "已归档: " & subFolder.Path
        Else
            Debug.Print "跳过（存在不符合条件的文件）: " & subFolder.Path
        End If
    Next subFolder
    
    MsgBox "归档任务完成", vbInformation
    Set fso = Nothing
End Sub

' 递归函数：验证指定文件夹下所有文件是否都早于归档日期
Private Function IsFolderQualified(targetFolder As Object, archiveDate As Date) As Boolean
    Dim file As Object
    Dim subFolder As Object
    
    ' 检查当前文件夹下的所有文件
    For Each file In targetFolder.Files
        ' 如果有任何一个文件的修改日期晚于阈值，直接返回False
        If file.DateLastModified >= archiveDate Then
            IsFolderQualified = False
            Exit Function
        End If
    Next file
    
    ' 递归检查所有子文件夹
    For Each subFolder In targetFolder.SubFolders
        If Not IsFolderQualified(subFolder, archiveDate) Then
            IsFolderQualified = False
            Exit Function
        End If
    Next subFolder
    
    ' 所有文件和子文件夹都达标，返回True
    IsFolderQualified = True
End Function

代码说明 #

• ArchiveQualifiedFolders：主函数，负责配置路径和日期，遍历待检查的父文件夹，调用验证函数后执行归档
• IsFolderQualified：递归验证函数，一旦发现任何一个文件不符合日期条件，立即终止检查并返回False，只有全部文件达标才返回True
• 使用FileSystemObject的CopyFolder方法直接复制整个文件夹结构，确保归档后目录层级和原目录一致
• 调试信息会输出到VBA编辑器的立即窗口，方便查看哪些文件夹被归档或跳过

使用注意事项 #

1. 修改sourceRootPath、archiveRootPath和archiveDate为你的实际参数
2. 可直接使用代码中的后期绑定CreateObject("Scripting.FileSystemObject")，无需额外引用库
3. 测试时建议先使用测试目录，避免误操作原文件

内容的提问来源于stack exchange，提问作者fing