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

[ChaseHammer]

Hi - 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

 

[ChaseHammer]

I was able to get this to work through some help in another forum but I wanted to post in case someone else could use the info:

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

 

[Peter_SSs]

I was able to get this to work through some help in another forum

Good to know that you got a solution and thanks for letting us know. For the future though, please tell us if you are posting your questions in multiple forums - see #13 of our Forum Rules

 

[ChaseHammer]

Good to know that you got a solution and thanks for letting us know. For the future though, please tell us if you are posting your questions in multiple forums - see #13 of our Forum Rules

Ah sorry about that. First time posting on here. Thanks for the info