VBA to loop through sub folders and place Word template in each folder

[JoeRooney]

Hi Guys,

I have been looking online but cant find anything matching my requirement and wanted to ask the question to see if it is possible. The requirement I have is I have a folder with 100's of individual sub folders, I need to place a blank word template that I have saved on the drive into each sub folder.

So I was thinking a loop is probably way to do this.

I am pretty sure this is possible but just not sure on how to go about it.

Any help is greatly appreciated.

I have some code that I have been using to select and move the folders to where I need them , I can attach if required.

Thanks
Joe

 

[John_w]

Use FileSystemObject to loop through the folders in the main folder and call the CopyFile method to copy the Word file.

 

[JoeRooney]

Thanks John ,

I have the below code that I used to move the folders I want to loop through and I think I can use this to use the copy file method and place them in the folder. But I am not sure where to apply the copy file method in the code , would you be able to assist me with this? Thanks for your help so far.

Thanks,



Sub Test1()
End Sub
Dim fDialog As FileDialog: Dim strTargetFolder As String: Dim strTestTracker As String: Dim wkbTestTracker As Workbook
Dim rgTestTrackerAccountNumbers As Range: Dim rg As Range: Dim strAccountNumber As String: Dim strMasterFolder As String
Dim fso As FileSystemObject: Dim mainFolder As Folder: Dim subFolder As Folder: Dim f As File
Dim strSourceFile As File

strSourceFile = "Z:\Test\Test.doc"
'Loop through the cells in the range to get the account number.
For Each rg In rgTestTrackerAccountNumbers.Cells
strAccountNumber = Trim(rg.Value)
'Loop through the subfolders and note the names. If the subfolder has the same name as the account, move that
'subfolder to the specified target folder.
For Each subFolder In mainFolder.SubFolders
If subFolder.Name = Trim(rg.Value) Then
'Move the subfolder to the specified path in (A)
fso.CopyFile , strSourceFile, subFolder.Path, strTargetFolder
Exit For
End If
Next subFolder
Next rg

exitSub:
'Clean-up the memory
Set wkbTestTracker = Nothing
Set fDialog = Nothing
Exit Sub

errorHandler:
MsgBox Err.Description
Resume exitSub
End Sub

 

[John_w]

Try this, changing the 2 lines of code where indicated to suit.

Public Sub Copy_File_To_Subfolders()

    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FSOfolder As Object 'Scripting.Folder
    Dim FSOsubfolder As Object 'Scripting.Folder
    Dim WordTemplate As String
    Dim mainFolder As String
    
    WordTemplate = "C:\path\to\template.docx" 'CHANGE THIS
    mainFolder = "C:\path\to\main folder" 'CHANGE THIS
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FileExists(WordTemplate) Then
        If FSO.FolderExists(mainFolder) Then
            Set FSOfolder = FSO.GetFolder(mainFolder)
            For Each FSOsubfolder In FSOfolder.SubFolders
                FSO.CopyFile WordTemplate, FSOsubfolder.Path & "\"
            Next
        Else
            MsgBox "Folder '" & mainFolder & "' doesn't exist"
        End If
    Else
        MsgBox "File to be copied '" & WordTemplate & "' doesn't exist"
    End If
    
End Sub

 

[JoeRooney]

Hi John ,

Works perfectly, thanks so much for your help.

Joe