基于Excel列表规则实现单源文件分至双目标文件夹的VBA需求

需求说明 #

现有VBA代码可从单个源文件夹复制指定文件到单个目标文件夹，需修改为：

• 1个源文件夹 + 2个目标文件夹（Destination_1、Destination_2）
• 将Sheet1中A1至A20单元格指定名称的文件复制到Destination_2
• 源文件夹中剩余所有文件复制到Destination_1

修改后的完整代码 #

Sub moveFilesToTwoDestinations()
    ' 文件夹路径常量，根据实际路径修改
    Const sPath As String = "E:\Source"
    Const dPath1 As String = "E:\Destination_1"
    Const dPath2 As String = "E:\Destination_2"
    ' 指定需要复制到Destination_2的单元格范围：A1-A20
    Const targetRange As String = "A1:A20"
    
    Dim ws As Worksheet: Set ws = Sheet1
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject ' Early Binding，需引用Microsoft Scripting Runtime
    ' Late Binding可替换为：Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 验证源文件夹路径
    Dim sFolderPath As String: sFolderPath = sPath
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
    If Not fso.FolderExists(sFolderPath) Then
        MsgBox "源文件夹路径 '" & sFolderPath & "' 不存在！", vbCritical
        Exit Sub
    End If
    
    ' 验证两个目标文件夹路径
    Dim dFolder1Path As String: dFolder1Path = dPath1
    If Right(dFolder1Path, 1) <> "\" Then dFolder1Path = dFolder1Path & "\"
    If Not fso.FolderExists(dFolder1Path) Then
        MsgBox "目标文件夹1路径 '" & dFolder1Path & "' 不存在！", vbCritical
        Exit Sub
    End If
    
    Dim dFolder2Path As String: dFolder2Path = dPath2
    If Right(dFolder2Path, 1) <> "\" Then dFolder2Path = dFolder2Path & "\"
    If Not fso.FolderExists(dFolder2Path) Then
        MsgBox "目标文件夹2路径 '" & dFolder2Path & "' 不存在！", vbCritical
        Exit Sub
    End If
    
    ' 收集A1-A20中的文件名到集合，用于快速判断
    Dim targetFiles As New Collection
    Dim cell As Range
    For Each cell In ws.Range(targetRange)
        Dim fileName As String: fileName = Trim(CStr(cell.Value))
        If Len(fileName) > 0 Then
            ' 支持部分匹配，这里用"包含"规则，如需"开头匹配"可改为 fileName & "*"
            targetFiles.Add "*" & fileName & "*", Key:=UCase(fileName)
        End If
    Next cell
    
    Dim sFile As File
    Dim destPath As String
    Dim countToDest1 As Long, countToDest2 As Long
    Dim existsInDest1 As Long, existsInDest2 As Long
    
    ' 遍历源文件夹所有文件
    For Each sFile In fso.GetFolder(sFolderPath).Files
        Dim isTargetFile As Boolean: isTargetFile = False
        
        ' 判断当前文件是否属于A1-A20指定的文件
        Dim key As Variant
        For Each key In targetFiles
            If fso.GetFileName(sFile.Path) Like key Then
                isTargetFile = True
                Exit For
            End If
        Next key
        
        ' 根据判断结果选择目标文件夹
        If isTargetFile Then
            destPath = dFolder2Path & sFile.Name
            If Not fso.FileExists(destPath) Then
                fso.CopyFile sFile.Path, destPath
                countToDest2 = countToDest2 + 1
            Else
                existsInDest2 = existsInDest2 + 1
            End If
        Else
            destPath = dFolder1Path & sFile.Name
            If Not fso.FileExists(destPath) Then
                fso.CopyFile sFile.Path, destPath
                countToDest1 = countToDest1 + 1
            Else
                existsInDest1 = existsInDest1 + 1
            End If
        End If
    Next sFile
    
    ' 显示处理结果
    MsgBox "处理完成：" & vbCrLf & _
        "复制到Destination_1：" & countToDest1 & "个（已存在：" & existsInDest1 & "个）" & vbCrLf & _
        "复制到Destination_2：" & countToDest2 & "个（已存在：" & existsInDest2 & "个）", vbInformation
End Sub

代码关键修改说明 #

• 多目标文件夹配置：新增dPath1和dPath2常量，分别对应两个目标文件夹，同时新增路径验证逻辑
• 目标文件集合：将Sheet1的A1-A20单元格内容收集到集合中，支持部分文件名匹配（默认"包含"规则，可修改为"开头匹配"）
• 全文件遍历：直接遍历源文件夹所有文件，避免遗漏未在列表中的文件
• 分类复制逻辑：判断每个文件是否属于指定列表，分别复制到对应目标文件夹
• 结果统计：新增两个目标文件夹的复制计数和已存在文件计数，最后弹出提示框展示处理结果

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