续开发VBA代码：筛选目标文件夹内最新文件夹并复制指定Excel文件

我们将在原CopyAllFolders过程末尾添加三个扩展功能的实现，完成以下目标：

• 遍历目标路径下的所有子文件夹，解析名称中的mmmyy年月信息
• 对比解析出的日期，筛选出时间最新的文件夹
• 在最新文件夹内查找符合命名规则的Excel文件，复制到目标根路径

修改后的完整代码 #

Sub CopyAllFolders(folders As Collection, destFolderPath As String)
    Dim fso As Object
    Dim folderPath As Variant
    Dim folderName As String
    Dim monthFolderName As String
    Dim yearFolderName As String
    Dim typeFolderName As String
    Dim newFolderPath As String
    
    ' 新增变量：用于扩展功能
    Dim destSubFolder As Object
    Dim latestDate As Date
    Dim latestFolderPath As String
    Dim targetFile As Object
    Dim filePatterns As Variant
    Dim pattern As Variant
    
    ' 初始化FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 确保目标文件夹存在
    If Dir(destFolderPath, vbDirectory) = "" Then
        MkDir destFolderPath
    End If
    
    ' 遍历待复制文件夹集合，执行原复制逻辑
    For Each folderPath In folders
        ' 提取当前文件夹名称
        folderName = fso.GetFolder(folderPath).Name
    
        ' 提取上级年月文件夹名称
        monthFolderName = fso.GetFolder(fso.GetParentFolderName(folderPath)).Name
        
        ' 提取上级年份文件夹名称
        yearFolderName = fso.GetFolder(fso.GetParentFolderName(fso.GetParentFolderName(folderPath))).Name
        
        ' 提取最上级类型文件夹名称
        typeFolderName = fso.GetFolder(fso.GetParentFolderName(fso.GetParentFolderName(fso.GetParentFolderName(folderPath)))).Name
        
        ' 将"mmm-yy"格式转换为"mmmyy"（如"Sep-23"转为"Sep23"）
        monthFolderName = Format(DateValue("01-" & monthFolderName), "mmmyy")
        
        ' 构建目标文件夹路径：[类型]-[mmmyy]
        newFolderPath = destFolderPath & "\" & typeFolderName & "-" & monthFolderName
        
        ' 确保目标子文件夹存在
        If Dir(newFolderPath, vbDirectory) = "" Then
            MkDir newFolderPath
        End If
    
        ' 检查源文件夹是否存在，执行复制操作
        If fso.FolderExists(folderPath) Then
            On Error Resume Next ' 忽略复制过程中的错误
            fso.CopyFolder source:=folderPath, destination:=newFolderPath, OverwriteFiles:=True
            If Err.Number <> 0 Then
                MsgBox "复制文件夹失败: " & folderPath & " 到 " & newFolderPath & vbCrLf & "错误信息: " & Err.Description
                Err.Clear
            End If
            On Error GoTo 0 ' 恢复正常错误处理
        Else
            MsgBox "源文件夹不存在: " & folderPath
        End If
    Next folderPath
    
    ' -------------------------- 扩展功能实现 --------------------------
    ' 1. 初始化最新日期和文件夹路径
    latestDate = DateSerial(1900, 1, 1)
    latestFolderPath = ""
    
    ' 遍历目标路径下的所有子文件夹
    For Each destSubFolder In fso.GetFolder(destFolderPath).SubFolders
        ' 提取文件夹名称末尾的mmmyy部分（假设格式为[type]-mmmyy）
        Dim dateStr As String
        dateStr = Right(destSubFolder.Name, 5)
        
        ' 尝试转换为日期，跳过格式不符合的文件夹
        On Error Resume Next
        Dim folderDate As Date
        folderDate = DateValue("01-" & dateStr)
        If Err.Number = 0 Then
            ' 对比日期，更新最新文件夹记录
            If folderDate > latestDate Then
                latestDate = folderDate
                latestFolderPath = destSubFolder.Path
            End If
        End If
        On Error GoTo 0
    Next destSubFolder
    
    ' 检查是否找到有效文件夹
    If latestFolderPath = "" Then
        MsgBox "未找到格式为mmmyy的目标文件夹"
        GoTo Cleanup
    End If
    
    ' 2. 定义要查找的文件通配符（支持xls/xlsx格式）
    filePatterns = Array("FP Sizing - * - Temp.xlsx", "FP Resizing - * - Temp.xlsx", _
                        "FP Sizing - * - Temp.xls", "FP Resizing - * - Temp.xls")
    
    ' 遍历每个通配符，查找并复制文件
    For Each pattern In filePatterns
        On Error Resume Next
        Set targetFile = fso.GetFile(latestFolderPath & "\" & pattern)
        If Err.Number = 0 Then
            targetFile.Copy destFolderPath & "\", OverWriteFiles:=True
            MsgBox "成功复制文件: " & targetFile.Name & " 到 " & destFolderPath
        Else
            ' 文件未找到时跳过，其他错误提示
            If Err.Number <> 53 Then
                MsgBox "复制文件失败: " & pattern & vbCrLf & "错误信息: " & Err.Description
            End If
            Err.Clear
        End If
        On Error GoTo 0
    Next pattern
    
Cleanup:
    ' 释放对象
    Set fso = Nothing
    Set destSubFolder = Nothing
    Set targetFile = Nothing
End Sub

关键实现说明 #

• 年月解析逻辑：通过Right(destSubFolder.Name, 5)提取文件夹名称末尾的mmmyy格式字符串，添加01-前缀后用DateValue转换为日期，确保能正确比较时间先后
• 最新文件夹筛选：初始化一个极早的日期（1900年1月1日），遍历所有子文件夹时不断更新最大日期对应的文件夹路径
• 文件匹配规则：使用通配符*匹配Requestname变量部分，同时支持.xls和.xlsx两种Excel格式，复制时自动覆盖目标路径下已存在的同名文件
• 错误处理：对格式不符合的文件夹、不存在的文件添加跳过逻辑，避免程序崩溃

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