Question

我正在寻找一种从单个文件夹复制多个文件的方法，并使用Access vba中的FileDialog将这组文件复制到多个文件夹。下面是我到目前为止 - 这段代码的问题是我只能将多个文件从一个文件夹复制到另一个文件夹。任何人都可以帮忙解决这个问题：

Public Function CopyFilesToFolders()

On Error GoTo Err_Copy

Dim sourcefiles As String
Dim destination As String
Dim source As String

    With Application.FileDialog(msoFileDialogFolderPicker)

        .Title = "Select a folder that contains the desired files to copy."

        If .Show = -1 Then source = .SelectedItems(1)
        If Len(source) = 0 Then Exit Function
        .AllowMultiSelect = True

        .Title = "Select a folder location to copy the files."

        If .Show = -1 Then destination = .SelectedItems(1)
        If Len(destination) = 0 Then Exit Function

    End With

sourcefiles = Dir$(source & "\*.*")

    Do While Len(sourcefiles) > 0

        FileCopy (source & "\" & sourcefiles), (destination & "\" & sourcefiles)

        sourcefiles = Dir$

    Loop

Exit_Copy:

    Exit Function

Err_Copy:
    CopyFilesToFolders = True
    MsgBox Error$
    Resume Exit_Copy

MsgBox "Task Complete!"

End Function

谢谢你，人

Answer 1

所以你希望该函数自动检测所有子文件夹并将所选文件复制到它们？您可以使用FileSystemObject检测所有子文件夹，然后将文件复制到它们。见这个修改过的函数：

Public Function CopyFilesToFolders()

On Error GoTo Exit_Copy

Dim sourcefiles As String
Dim destination As String
Dim source As String

Dim FileSystem As Object

Set FileSystem = CreateObject("Scripting.FileSystemObject")

    With Application.FileDialog(msoFileDialogFolderPicker)

        .Title = "Select a folder that contains the desired files to copy."

        If .Show = -1 Then source = .SelectedItems(1)
        If Len(source) = 0 Then Exit Function
        .AllowMultiSelect = True

        .Title = "Select a folder location to copy the files."

        If .Show = -1 Then destination = .SelectedItems(1)

        If Len(destination) = 0 Then Exit Function


    End With

sourcefiles = Dir$(source & "\*.*")

Dim SubFolder

    Do While Len(sourcefiles) > 0

        For Each SubFolder In FileSystem.GetFolder(destination).SubFolders
            FileCopy (source & "\" & sourcefiles), (SubFolder.path & "\" & sourcefiles)
        Next

        sourcefiles = Dir$

    Loop

Exit_Copy:

    Exit Function

End Function

Answer 2

很抱歉，稍微更改主题，但我认为int在Excel中更容易实现，而不是在Access中。请参阅下面的示例。

Sub sbCopyingAFile()

'Declare Variables
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String

'This is Your File Name which you want to Copy
sFile = "Sample.xls"

'Change to match the source folder path
sSFolder = "C:\Temp\"

'Change to match the destination folder path
sDFolder = "D:\Job\"

'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
    MsgBox "Specified File Not Found", vbInformation, "Not Found"

'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
    FSO.CopyFile (sSFolder & sFile), sDFolder, True
    MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
    MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If

End Sub

现在，如果要动态列出文件夹中的文件，单个单元格中的每个文件路径，然后确切地指定要从一个文件夹复制到另一个文件夹的文件，那肯定是可行的。首先，尝试上面的示例代码，并为将来的增强功能提供反馈。

使用Access vba中的FileDialog将多个文件复制到多个文件夹

2 个答案: