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

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

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

1 个答案: