将文件列表从多个文件夹复制到一个目标文件夹

Question

我想使用带有文件名列表的 Excel 文档将列出的文件从多个文件夹复制到一个目标文件夹。

以下代码有效，但是，有 150 个文件夹，我不想为每个文件夹命名。

如何在目录中的所有文件夹中查找文件？我希望我可以用“O:*”替换“O:\96”，但通配符似乎不适用于文件夹。大多数文件夹名称是 10-200 之间的数字，但也有一些是文本。

如何将文件复制功能指向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