Verschieben Sie nur Dateien mit übereinstimmenden Dateinamen von einem Ordner in einen anderen Ordner

Question

Ich möchte nur die Dateien aus einem Ordner "FromPath" kopieren, die denselben Dateinamen (mit unterschiedlichen Erweiterungen) haben wie in einem anderen Ordner "the ToPath" . Nur die freigegebene Datei namens Dateien wird verschoben. Ich denke, der Code müsste zuerst im ToPath-Ordner suchen, um die Namen der Dateien abzurufen und dann die Querverweise auf die im "FromPath" -Ordner anzuhängen.

Dank

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

Sie haben ziemlich viel es. Ich habe ein paar kleine Ergänzungen gemacht. Zuerst mache ich eine eindeutige Liste von lokalen Dateien in der colFiles Sammlung. Ich habe dies getan, weil Sie auf einen Remote-Server kopieren. Ich denke, es wird wahrscheinlich schneller so sein. Sobald Sie die Liste der lokalen Dateien haben, durchlaufen Sie einfach die Überprüfung der Sammlung, um zu sehen, ob sie im Remote-Ordner vorhanden sind, und kopieren sie, falls dies der Fall ist.

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