僅將文件名匹配的文件從一個文件夾移動到另一個文件夾

Question

我只想復制一個文件夾“the FromPath”中與另一個文件夾“the ToPath”具有相同文件名（具有不同擴展名）的文件。 只會移動名為 files 的共享文件。 我認為代碼必須首先查看 ToPath 文件夾以獲取文件名，然后交叉引用“FromPath”文件夾中的文件名。

謝謝

Private Sub CmdBtn_transfer_Click()

Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim Val As String
Dim i As Integer

FromPath = "C:\Users\rossi\Desktop\Production files\" & (Me.ListBox1) '<< Change

For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
    Val = ListBox2.List(i)
End If
Next i
FileExt = "*.sli*"  '<< Change

If Right(FromPath, 1) <> "\" Then
    FromPath = FromPath & "\"
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
    MsgBox FromPath & " doesn't exist"
    Exit Sub
End If

For i = 0 To ListBox2.ListCount - 1
    If ListBox2.Selected(i) Then
        ToPath = "\\bego.hb\MED_PRODUCTION\USA_Datapreparation\" & (Me.ListBox2.List(i))    '<< Change

        If Right(ToPath, 1) <> "\" Then
            ToPath = ToPath & "\"
        End If

        If FSO.FolderExists(ToPath) = False Then
            MsgBox ToPath & " doesn't exist"
            Exit Sub
        End If

        FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
        MsgBox "You can find the files from " & FromPath & " in " & ToPath
    End If
Next i

End Sub

Answer 1

你幾乎擁有它。 我做了一些小的補充。 首先，我在colFiles集合中創建一個唯一的本地文件列表。 我這樣做是因為您要復制到遠程服務器。 我認為這樣可能會更快。 獲得本地文件列表后，您只需循環檢查集合以查看它們是否存在於遠程文件夾中，如果存在則復制它們。

Private Sub CmdBtn_transfer_Click()

Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim Val As String
Dim i As Integer
Dim x As Integer
Dim colFiles As New Collection
Dim strFilename As String

FromPath = "C:\Users\rossi\Desktop\Production files\" & (Me.ListBox1) '<< Change

For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
    Val = ListBox2.List(i)
End If
Next i
FileExt = "*.sli*"  '<< Change

If Right(FromPath, 1) <> "\" Then
    FromPath = FromPath & "\"
End If

If FSO.FolderExists(FromPath) = False Then
    MsgBox FromPath & " doesn't exist"
    Exit Sub
End If

'Create a list of local filenames
strFilename = Dir(FromPath & "*" & FileExt) 'Corrected
While strFilename <> ""
    colFiles.Add Left(strFilename, _
                 InStr(1, strFilename, ".", vbBinaryCompare) - 1), _
                 Left(strFilename, InStr(1, strFilename, ".", vbBinaryCompare) - 1)
    strFilename = Dir()
Wend

Set FSO = CreateObject("scripting.filesystemobject")

For i = 0 To ListBox2.ListCount - 1
    If ListBox2.Selected(i) Then
        ToPath = "\\bego.hb\MED_PRODUCTION\USA_Datapreparation\" & (Me.ListBox2.List(i))    '<< Change

        If Right(ToPath, 1) <> "\" Then
            ToPath = ToPath & "\"
        End If

        If FSO.FolderExists(ToPath) = False Then
            MsgBox ToPath & " doesn't exist"
            Exit Sub
        End If

        'Now loop through our list of files to see if they exist on the remote server
        For x = 1 To colFiles.Count 'Corrected
            If FSO.FileExists(ToPath & colFiles.item(x) & FileExt) Then
                FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
            End If
        Next

        MsgBox "You can find the files from " & FromPath & " in " & ToPath
    End If
Next i

End Sub