Copying 1 file into multiple subdirectories - excel

Question

I have found one code snippet that successfully copies 1 file to one specific directory. However what I am trying to piece together is a way to copy one file into hundreds of subdirectories. I have also found code that recursively cycles through subfolders and allows you to take action upon the files in the subfolders. Surely there must be a mash up of these two codes that would allow me to copy the 1 file into numerous subdirectories.
If this is not possible I have working code for a command prompt.
Sub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath.
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim fso As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
'FromPath = "C:\Users\Ron\Data" '<< Change
'ToPath = "C:\Users\Ron\Test" '<< Change
FileExt = "*.pdf" '<< Change
'You can use *.* for all files or *.doc for Word files
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
Set fso = CreateObject("scripting.filesystemobject")
If fso.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If fso.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
fso.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
Code that cycles through subfolders:
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
' Operate on each file
Next
End Sub
Any advice is welcome!

Answer 1

Try the following code:
'*****************************************************
' FUNCTION HEADER: Put_A_File_In_All_Subfolders
'
' Purpose: Looks for the specified file, and if it exists it
' puts the file in all subfolders of the target path.
'
' Inputs:
' blnFirstIteration: True / false for whether this is the first function call
' strFromPath As String: The path where the file to copy is located.
' strToPath As String: The path where the destination folder tree exists.
' strFileToCopy: The filename to copy.
'*****************************************************
Sub Put_A_File_In_All_Subfolders( _
blnFirstIteration As Boolean, _
strFromPath As String, _
strToPath As String, _
strFileToCopy As String)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim blnEverythingIsValid As Boolean
blnEverythingIsValid = True
'If this is the first run, check to make sure the initial file
'exists at that path, else throw error messages:
If blnFirstIteration Then
If Right(strFromPath, 1) <> "\" Then
strFromPath = strFromPath & "\"
End If
If fso.FolderExists(strFromPath) = False Then
MsgBox strFromPath & " doesn't exist"
blnEverythingIsValid = False
Else
If Not fso.FileExists(strFromPath & strFileToCopy) Then
MsgBox strFileToCopy & " doesn't exist in " & strFromPath
blnEverythingIsValid = False
End If
End If
If fso.FolderExists(strToPath) = False Then
MsgBox strToPath & " doesn't exist"
blnEverythingIsValid = False
End If
End If
If blnEverythingIsValid Then
If Right(strToPath, 1) <> "\" Then
strToPath = strToPath & "\"
End If
'Copy the file to the destination folder
fso.CopyFile (strFromPath & strFileToCopy), strToPath, True
'Run the sub recursively for each subfolder
Dim vntSubFolder As Variant
Dim currentFolder As Scripting.Folder
Set currentFolder = fso.GetFolder(strToPath)
'Check to see if there are subfolders
If currentFolder.SubFolders.Count > 0 Then
For Each vntSubFolder In currentFolder.SubFolders
'Dim fsoSubFolder As Scripting.Folder
'Set fsoSubFolder = currentFolder.SubFolders.item(vntSubFolder)
Dim strSubFolderPath As String
strSubFolderPath = vntSubFolder.Path
Put_A_File_In_All_Subfolders False, strFromPath, strSubFolderPath, strFileToCopy
Next vntSubFolder
End If
Else
Set fso = Nothing
Exit Sub
End If
Set fso = Nothing
End Sub
You can call it using:
Put_A_File_In_All_Subfolders True, "C:\PathWithFile\", "C:\RootDestinationFolder", "Filename.ext"
I mashed that up quickly, so please test before using widely...