VBA - Copy Files with Prefix to Multiple Destinations Based on Cell Value

Question

First time on this forum and was hoping someone could help me out...

I am trying to copy any and all pdf files with a prefix of TT Plan from a single source folder (specified in cell C3) to a series of destination folders based on a specific main directory, then subfolder names as the job numbers in cells B8 through however many job numbers I have.

Below is what I was trying, though I know this is setup incorrectly for the destination folder.

Sub CopyFiles()

    Dim LastRowInA As Long
    Dim Cel As Range
    Dim Rng As Range
    Dim DestinationFolder As String
    Dim FileExtention As String
    Dim SourceFile As String
    Dim SourceFolder As String

    On Error Resume Next

    SourceFolder = TTPlanCopy.Range("C4") & "\"
    FileExtention = "pdf"
    DestinationFolder = "F:\UFP Design\Report Testing\Jobs\"


    If Dir(DestinationFolder, vbDirectory) = 0 Then
        MsgBox ("Job Folder does not exist")
        Exit Sub
    End If

    SourceFile = Dir(SourceFolder & "TT Plan*." & FileExtention)

    LastRowInB = Range("B" & Rows.Count).End(xlUp).Row

    Set Rng = Range("B8:B" & LastRowInB)

    With Rng
        For Each Cel In Rng
        Do While SourceFile Like "TT Plan*"
        FileCopy SourceFolder & SourceFile, DestinationFolder & Cel
        SourceFile = Dir
        Loop
        Next
    End With
End Sub

Answer 1

Copy the Same Files to Multiple Folders

Sub CopyFiles()
    
    ' Constants
    
    Const SRC_FOLDER_CELL As String = "C4"
    Const FILE_EXTENSION As String = "pdf"
    Const FILE_BASE_NAME_PATTERN As String = "TT Plan*"
    Const DST_SUBFOLDERS_FIRST_CELL As String = "B8"
    Const DST_ROOT_FOLDER As String = "F:\UFP Design\Report Testing\Jobs\"

    ' Source

    Dim ws As Worksheet: Set ws = TTPlanCopy

    Dim sFolderPath As String:
    sFolderPath = CStr(ws.Range(SRC_FOLDER_CELL).Value) & "\"
    
    If Len(Dir(sFolderPath, vbDirectory)) = 0 Then
        MsgBox "The source path """ & sFolderPath _
            & """ does not exist!", vbExclamation
        Exit Sub
    End If
    
    Dim FilePattern As String:
    FilePattern = FILE_BASE_NAME_PATTERN & "." & FILE_EXTENSION
    
    Dim sFileName As String: sFileName = Dir(sFolderPath & FilePattern)
        
    If Len(sFileName) = 0 Then
        MsgBox "No files found in source path """ _
            & sFolderPath & """!", vbExclamation
        Exit Sub
    End If
        
    Dim scollFileNames As Collection: Set scollFileNames = New Collection
        
    Do While Len(sFileName) > 0
        scollFileNames.Add sFileName
        sFileName = Dir
    Loop
    
    ' Destination
    
    Dim rg As Range, rCount As Long
        
    With ws.Range(DST_SUBFOLDERS_FIRST_CELL)
        rCount = ws.Cells(ws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If rCount < 1 Then
            MsgBox "No subfolder data found starting in cell """ _
                & DST_SUBFOLDERS_FIRST_CELL & """ of worksheet """ _
                & ws.Name & """!", vbExclamation
            Exit Sub
        End If
        Set rg = .Resize(rCount)
    End With
    
    If Len(Dir(DST_ROOT_FOLDER, vbDirectory)) = 0 Then
        MsgBox "The destination folder """ & DST_ROOT_FOLDER _
            & """ does not exist!", vbExclamation
        Exit Sub
    End If
    
    Dim dData() As Variant
    
    If rCount = 1 Then
        ReDim dData(1 To 1, 1 To 1): dData(1, 1) = rg.Value
    Else
        dData = rg.Value
    End If
    
    Dim dcollFolderPaths As Collection: Set dcollFolderPaths = New Collection
    
    Dim dSubfolderName As Variant, r As Long, dSubfolderPath As String
    
    For r = 1 To rCount
        dSubfolderName = dData(r, 1)
        If Not IsError(dSubfolderName) Then
            If Len(dSubfolderName) > 0 Then
                dSubfolderPath = DST_ROOT_FOLDER & dSubfolderName & "\"
                If Len(Dir(dSubfolderPath, vbDirectory)) = 0 Then
                    MkDir dSubfolderPath
                End If
                dcollFolderPaths.Add dSubfolderPath
            End If
        End If
    Next r
        
    If dcollFolderPaths.Count = 0 Then  ' only blanks and errors
        MsgBox "No jobs found.", vbExclamation
        Exit Sub
    End If
        
    ' Copy.
    
    Dim sItem As Variant, dItem As Variant, sFilePath As String
        
    For Each sItem In scollFileNames
        sFilePath = sFolderPath & sItem
        For Each dItem In dcollFolderPaths
            FileCopy sFilePath, dItem & sItem
        Next dItem
    Next sItem
 
    MsgBox "Files copied to Job Folders.", vbInformation
 
End Sub