生产环境下使用Excel宏创建目录并从共享位置复制文件

生产环境中存在大量带序列号（如SNO_01、SNO_02等）的文件夹，需完成以下操作：

• 在已存在的Location B对应序列号文件夹下创建REISSUE空文件夹
• 将Location A对应序列号ORIGINAL目录下的文件复制至该REISSUE文件夹

现有自行编写的VBA宏脚本存在错误，以下是修正后的实现方案：

原错误脚本 #

Sub CreateFolderCopyFiles()
'Macro to copy all files

 Dim n As String, msg As String, d As Date
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set fils = fso.GetFolder("D:\UKRR\Parent_Folder\& SNO_01 &\Original").Files

'Verify all files in the folder, check the modification date and then copy 
'to another folder (named Old)
For Each fil In fils
n = fil.Name
d = fil.DateLastModified
If d >= Date - 1 Then
    file = n
    'The following line is where the error occurs
    fso.CopyFile "D:\UKRR\Parent_Folder\& SNO_01 &\Original", 
"D:\UKRR\Child_Folder\\& SNO_01 &\Reissue"
'Reissue is the new Folder has to create while runtime

End If
Next fil

End Sub

修正后的批量处理脚本 #

Sub BatchCreateReissueAndCopyFiles()
    Dim fso As Object
    Dim parentFolder As Object
    Dim serialFolder As Object
    Dim originalFolder As Object
    Dim targetReissueFolder As String
    Dim sourceBasePath As String
    Dim targetBasePath As String
    Dim fil As Object
    
    ' 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 定义Location A和Location B的基础路径
    sourceBasePath = "D:\UKRR\Parent_Folder\"
    targetBasePath = "D:\UKRR\Child_Folder\"
    
    ' 获取Location A下的所有根文件夹
    Set parentFolder = fso.GetFolder(sourceBasePath)
    
    ' 遍历每个序列号文件夹
    For Each serialFolder In parentFolder.SubFolders
        ' 过滤出SNO_开头的序列号文件夹
        If Left(serialFolder.Name, 4) = "SNO_" Then
            ' 构建ORIGINAL文件夹路径
            Dim originalPath As String
            originalPath = sourceBasePath & serialFolder.Name & "\Original\"
            
            ' 检查ORIGINAL文件夹是否存在
            If fso.FolderExists(originalPath) Then
                ' 构建目标REISSUE文件夹路径
                targetReissueFolder = targetBasePath & serialFolder.Name & "\REISSUE\"
                
                ' 不存在则创建REISSUE文件夹
                If Not fso.FolderExists(targetReissueFolder) Then
                    fso.CreateFolder targetReissueFolder
                End If
                
                ' 获取ORIGINAL文件夹下的文件集合
                Set originalFolder = fso.GetFolder(originalPath)
                
                ' 复制最近1天内修改的文件到REISSUE文件夹
                For Each fil In originalFolder.Files
                    If fil.DateLastModified >= Date - 1 Then
                        ' True参数表示覆盖已存在的同名文件
                        fso.CopyFile fil.Path, targetReissueFolder & fil.Name, True
                    End If
                Next fil
            End If
        End If
    Next serialFolder
    
    ' 释放对象资源
    Set fso = Nothing
    Set parentFolder = Nothing
    Set serialFolder = Nothing
    Set originalFolder = Nothing
    
    MsgBox "批量处理完成！", vbInformation
End Sub

原脚本错误说明及修正要点 #

原脚本核心错误 #

• 字符串拼接逻辑错误：直接在路径字符串中写& SNO_01 &，不符合VBA变量拼接语法，导致路径无效
• 无批量处理能力：仅针对固定的SNO_01文件夹，无法遍历所有序列号文件夹
• CopyFile方法调用错误：该方法需要指定具体文件路径，而非文件夹路径
• 缺少文件夹创建逻辑：未判断REISSUE文件夹是否存在，直接复制会触发异常

修正后的关键优化 #

• 自动遍历所有SNO_开头的文件夹，实现批量处理
• 采用正确的路径拼接方式，确保路径有效性
• 增加文件夹存在性检查，自动创建不存在的REISSUE文件夹
• 正确调用CopyFile方法，指定单个文件路径完成复制
• 增加对象资源释放和处理完成提示，提升脚本健壮性

内容的提问来源于stack exchange，提问作者Antony Prince Peter