將文件列表從多個文件夾復制到一個目標文件夾

Question

我想使用帶有文件名列表的 Excel 文檔將列出的文件從多個文件夾復制到一個目標文件夾。

下面的代碼有效，但是，有 150 個文件夾，我不想為每個文件夾命名。

如何在目錄中的所有文件夾中查找文件？ 我希望我可以用“O:*”替換“O:\96”，但通配符似乎不適用於文件夾。 大多數文件夾名稱是 10-200 之間的數字，但也有一些是文本。

如何將文件副本 function 指向 O 盤上的所有文件夾？

Sub CopyFiles_Fd1_to_Fd2()
    
    Dim i As Long
    
    On Error Resume Next
    MkDir "C:\PACKAGED DWGS"
    On Error GoTo 0
    
    For i = 1 To 5000
        FileCopy "O:\95\" & Sheets(1).Cells(i, 1).Value, "C:\PACKAGED DWGS\" & Sheets(1).Cells(i, 1).Value
        On Error Resume Next
        FileCopy "O:\96\" & Sheets(1).Cells(i, 1).Value, "C:\PACKAGED DWGS\" & Sheets(1).Cells(i, 1).Value
        On Error Resume Next
        FileCopy "O:\97\" & Sheets(1).Cells(i, 1).Value, "C:\PACKAGED DWGS\" & Sheets(1).Cells(i, 1).Value
        On Error Resume Next
        FileCopy "O:\98\" & Sheets(1).Cells(i, 1).Value, "C:\PACKAGED DWGS\" & Sheets(1).Cells(i, 1).Value
        On Error Resume Next
    Next
    
End Sub

Answer 1

Microsoft 腳本運行時“伴侶”

• 調整常量部分中的值。
• 使用VBE>Tools>References創建對Microsoft Scripting Runtime的引用。

編碼

Option Explicit

' VBE-Tools-References-Microsoft Scripting Runtime
Sub copyFiles()
    
    ' Define constants.
    Const srcDrive As String = "O"
    Const dstPath As String = "C:\PACKAGED DWGS"
    Const wsName As String = "Sheet1"
    Const First As String = "A2"
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Write file names from worksheet to Files Data array.
    Dim FilesData As Variant
    With wb.Worksheets(wsName)
        FilesData = .Range(First).Resize(.Cells(.Rows.Count, _
            .Range(First).Column).End(xlUp).Row - .Range(First).Row + 1)
    End With
    'Debug.Print Join(Application.Transpose(Data), vbLf)
 
    ' Create a list of files (Dictionary) to be copied.
    Dim dict As Scripting.Dictionary
    Set dict = New Dictionary
    Dim fso As Scripting.FileSystemObject
    Set fso = New FileSystemObject
    Dim fsoDrive As Drive
    Set fsoDrive = fso.GetDrive(srcDrive)
    Dim fsoFolder As Folder
    Dim fsoFile As File
    Dim cMatch As Variant
    For Each fsoFolder In fsoDrive.RootFolder.SubFolders
        If fsoFolder.Attributes <> 22 Then ' exclude Recycle Bin and Sys.Inf.
            For Each fsoFile In fsoFolder.Files
                cMatch = Application.Match(fsoFile.Name, FilesData, 0)
                If Not IsError(cMatch) Then
                    If Not dict.Exists(fsoFile.Name) Then ' ensure unique.
                        dict(fsoFile.Name) = fsoFile.Path
                    End If
                End If
            Next fsoFile
        End If
    Next fsoFolder
    'Debug.Print Join(dict.Keys, vbLf) & Join(dict.Items, vbLf)
    
    ' Copy files to destination path.
    If Not fso.FolderExists(dstPath) Then
        MkDir dstPath
    End If
    Dim Key As Variant
    For Each Key In dict.Keys
        'On Error Resume Next
        fso.CopyFile dict(Key), dstPath & "\" & Key
        'On Error GoTo 0
    Next Key
    wb.FollowHyperlink dstPath

End Sub