Access VBA中用FileDialog实现多文件复制至多文件夹的技术求助

我明白你现在的需求是要把单个源文件夹里的多组文件复制到多个目标文件夹里，而不是单一目标。你的原代码只支持选择一个目标文件夹，所以咱们得调整FileDialog的设置，让用户可以选择多个目标文件夹，同时修改复制逻辑来遍历每个目标完成文件复制。

原代码的核心局限 #

你的原代码应该是用了msoFileDialogFolderPicker但没开启多选功能（AllowMultiSelect = False是默认值），所以只能选一个目标文件夹。要实现多目标复制，首先得把目标文件夹选择器改成支持多选。

修改后的完整代码 #

下面是调整后的完整代码，包含了多目标选择、文件遍历和批量复制的逻辑，还有错误处理：

Public Function CopyFilesToFolders()
    On Error GoTo Err_Copy
    
    Dim fdSource As FileDialog
    Dim fdDestinations As FileDialog
    Dim sourceFolder As String
    Dim destFolder As Variant
    Dim sourceFile As String
    
    ' 第一步：选择源文件夹（只能选一个，符合你的需求）
    Set fdSource = Application.FileDialog(msoFileDialogFolderPicker)
    With fdSource
        .Title = "请选择包含待复制文件的源文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo Exit_Copy ' 用户取消选择，直接退出
        sourceFolder = .SelectedItems(1) & "\" ' 确保路径末尾带反斜杠，避免拼接出错
    End With
    
    ' 第二步：选择多个目标文件夹
    Set fdDestinations = Application.FileDialog(msoFileDialogFolderPicker)
    With fdDestinations
        .Title = "请选择一个或多个目标文件夹（可按住Ctrl/Shift多选）"
        .AllowMultiSelect = True
        If .Show <> -1 Then GoTo Exit_Copy ' 用户取消选择，直接退出
    End With
    
    ' 第三步：遍历每个目标文件夹，复制所有源文件
    For Each destFolder In fdDestinations.SelectedItems
        ' 获取源文件夹中的第一个文件
        sourceFile = Dir(sourceFolder & "*.*")
        
        ' 循环遍历源文件夹里的所有文件
        Do While sourceFile <> ""
            ' 复制当前文件到目标文件夹
            FileCopy sourceFolder & sourceFile, destFolder & "\" & sourceFile
            ' 获取下一个文件
            sourceFile = Dir()
        Loop
        MsgBox "文件已成功复制到: " & destFolder, vbInformation
    Next destFolder
    
Exit_Copy:
    ' 释放对象，避免内存泄漏
    Set fdSource = Nothing
    Set fdDestinations = Nothing
    Exit Function
    
Err_Copy:
    ' 错误提示
    MsgBox "复制过程中出现错误: " & Err.Description, vbExclamation
    Resume Exit_Copy
End Function

关键代码解释 #

• 多选目标文件夹：给目标文件夹选择器设置.AllowMultiSelect = True，用户就可以按住Ctrl选择不连续的文件夹，或者Shift选择连续的文件夹。
• 路径处理：在源文件夹路径末尾加上反斜杠\，是为了避免拼接文件路径时出现错误（比如C:\Sourcefile.txt这种错误路径）。
• 文件遍历：用Dir函数遍历源文件夹的所有文件，Dir(sourceFolder & "*.*")获取第一个文件，之后每次调用Dir()会自动获取下一个文件，直到返回空字符串表示遍历完成。
• 文件复制：用VBA内置的FileCopy语句，简单直接。如果需要覆盖已存在的文件或者更复杂的操作，可以改用FileSystemObject的CopyFile方法（需要先引用Microsoft Scripting Runtime）：

' 先在VBA编辑器的【工具】->【引用】中勾选"Microsoft Scripting Runtime"
Dim fso As New FileSystemObject
' 第三个参数设为True表示覆盖已存在的文件
fso.CopyFile sourceFolder & sourceFile, destFolder & "\", True

注意事项 #

1. 测试前请备份源文件，避免意外覆盖或丢失数据。
2. 如果源文件夹中有子文件夹，上述代码只会复制根目录的文件；如果需要复制子文件夹和其中的文件，可以扩展逻辑遍历子文件夹。
3. 如果文件过大或者数量过多，可能需要添加进度提示，提升用户体验。

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