Copy list of files from multiple folders to one destination folder

Question

I would like to use an Excel document with a list of filenames to copy the files listed from multiple folders to one destination folder.

The below code works, however, there are 150 folders and I don't want to have to name each one.

How do I look in all folders in a directory for the files? I was hoping I could replace "O:\96" with "O:*", but wildcards don't appear to work for folders. Most of the folder names are numbers ranging from 10-200, however, some are text.

How can I point the file copy function to all folders on the O drive?

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 Scripting Runtime 'Companions'

• Adjust the values in the constants section.
• Using VBE>Tools>References, create a reference to Microsoft Scripting Runtime.

The Code

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