Question

我只想复制具有相同文件名（具有不同扩展名）的文件夹“FromPath”中的文件，而不是另一个文件夹中的“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

仅将具有匹配文件名的文件从一个文件夹移动到另一个文件夹

1 个答案: