excel - VBA - 将多个选定的文件从一个文件夹复制到另一个

Question

我正在寻找一种方法来选择一个文件夹中的多个 .jpg 文件并将其复制到另一个文件夹。这是我正在使用的代码，但它似乎无法将其移动到目标文件。

我还使用了一个 excel 工作表，我在其中粘贴了我想在 A 行中复制的那些文件名。

Sub CopyFiles()

    Dim xDir As String
    Dim xFile As String
    Dim xRow As Long
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String
    Dim FNames As String

    FromPath = "Directory"  'Folder From
    ToPath = "Directory"   'Folder To

    Worksheets("Files to Copy").Activate

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False

        If .Show = -1 Then
            xDir = .SelectedItems(1)
            xFile = Dir(xDir & Application.PathSeparator & "*")
            Do Until xFile = ""
                xRow = 0
                On Error Resume Next
                xRow = Application.Match(xFile, Range("A:A"), 0)
                If xRow > 0 Then
                    Name xDir & Application.PathSeparator & xFile As _
                    ToPath & Cells(xRow, "B").Value
                End If
                xFile = Dir
            Loop
        End If
    End With
End Sub

标签： excelvba

Answer 1

Sub CopyFiles()

    '// Tools -> References -> Microsoft Scripting Runtime

    Dim xRow As Long
    Dim FSO As FileSystemObject
    Dim FromPath$, ToPath$
    Dim xFile As File
    Dim xFolder As Folder

    FromPath = "Directory"  'Folder From
    ToPath = "Directory"   'Folder To

    Worksheets("Files to Copy").Activate

    Set fso = New FileSystemObject
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If Not .Show Then Exit Sub
        Set xFolder = FSO.GetFolder(.SelectedItems(1))
        For Each xFile In xFolder.Files
            On Error Resume Next
            xRow = Application.Match(xFile.Name, Range("A:A"), 0)
            If Err = 0 Then
                xFile.Copy ToPath & Cells(xRow, "B").Value
            End If
            On Error GoTo 0
        Next
    End With

End Sub