Using VBA to loop through multiple Word Templates and fill them in with Excel Data

[AppellatePerson]

I am trying to put data from one row in an Excel file into a bunch of different Word templates at bookmarked locations. Each row in the spreadsheet pertains to an employee. Basically, I have over 30 document templates (for different purposes) that need to be filled out for about 20 different people. Then, I need to save those filled out documents as Word templates themselves. Each employee needs a personalized version of the template but it has to stay a template so that they can use it repeatedly to create new copies of those documents to edit for a particular customer.

Here is a dummy version of the type of data the Excel file will be putting into the templates at various locations:

For MrExcel Post.xlsm
	A	B	C	D	E
1	Employee Name	Employee Number	Email	Title	Initials
2	John Smith	123435	test@aol.com	Employee1	JS
3	Donald Duck	2346534	test2@aol.com	Employee2	DD
4	Tom Cruise	4687876	test3@aol.com	Employee3	TC
Names_Info

Mail merge is not the answer because I need to apply the information to thirty different template documents. Doing a mail merge creates one document containing the version for each employee. It is too cumbersome to do the mail merge and then separate that one output document into 20 different documents. And then repeat that whole process 29 more times for all the different templates.

I found an answer on Quora about using bookmarks in the Word template and a VBA module applying data from an Excel file. That answer from Danielle O'Connell is available here but here is the code:

Sub SendToMemo()
'Creates a new memo using the details of the selected row.
 
Dim wd As Object
Dim wdDoc As Object
Dim r As Integer
Dim h As Integer
Dim lCol As Integer
Dim strV As String
Dim strH As String
Dim strBM As String
Dim wdBM As Object
Dim i As Integer
 
'Create Word Document & Set Object References
    Set wd = CreateObject("Word.Application")
    Set wdDoc = wd.Documents.Add("C:\Users\danie\Documents\test\Test Template.dotx")
    wd.Visible = True
 
'Loop through each column and retreive heading text and cell text (strH = Heading Text, strV = cell Text)
    r = ActiveCell.row
    lCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
    h = 1
        While h <= lCol
            strH = Replace(Replace(Replace(Replace(ActiveSheet.Cells(1, h).Value, " ", "_"), ",", ""), "-", ""), ".", "")
            strV = ActiveSheet.Cells(r, h).Text
            strBM = strH
            i = 1
     
'Test if Bookmark named with column heading exists
lbTestBM:
        If wdDoc.Bookmarks.Exists(strBM) Then
            wdDoc.Bookmarks(strBM).Range.Text = strV
         
 'Test if multiple bookmarks with same name exist using column heading & iterating integer
                i = i + 1
                strBM = strH & "_" & i
                GoTo lbTestBM
            End If
        h = h + 1
        Wend
End Sub

This code worked like a charm for one of the Word templates but I need help to make it do what I need for all the documents.

The remaining problems I need to solve are how to get the VBA module to:

• apply the Excel data to more than one template file (about 30 files). One option I considered is putting all the templates into a single folder and then looping through every file in that folder.
• Have the output files be Word templates ( .dotm) files.
• "Save as" the new Word documents. Otherwise, I have to save 600 documents manually.
• Name the files with a descriptive name. Ideally, the name would be the employee's initials + the template title. I think this could be done by referring to the "Initials" column in the Excel file.
• Not a huge deal but it is probably best to have the files not open automatically when the VBA module creates them.

I have no VBA experience but have enjoyed tinkering with it so far. I learned some basic Java in college so I have a very basic understanding of coding principles. Please have mercy on me and help me out!

 

[John_w]

apply the Excel data to more than one template file (about 30 files). One option I considered is putting all the templates into a single folder and then looping through every file in that folder.

That option would work. The code would use a Dir() function loop to loop through all the files in the folder, or loop through files which match a wildcard file name.

Have the output files be Word templates ( .dotm) files.

Why macro-enabled templates (.dotm) and not normal templates (.dotx)?

• "Save as" the new Word documents. Otherwise, I have to save 600 documents manually.
• Name the files with a descriptive name. Ideally, the name would be the employee's initials + the template title. I think this could be done by referring to the "Initials" column in the Excel file.

The code can do a "Save As" with the file name "<Initials> Template file name"

 

[AppellatePerson]

That option would work. The code would use a Dir() function loop to loop through all the files in the folder, or loop through files which match a wildcard file name.


Why macro-enabled templates (.dotm) and not normal templates (.dotx)?


The code can do a "Save As" with the file name "<Initials> Template file name"

It could be normal templates (.dotx). Where should I put the Dir() loop and the "Save as" command?

 

[John_w]

The Dir() loop would be the outer loop, with nested loops for rows and columns. Pseudo-code something like this:

templateFile = Dir(templateFolder)
While templateFile <> ""
   For row = 2 to last row
       Open templateFile
       For column = 1 to last column
           Write cell value to bookmark with column heading
       Next
       Save template as new template with column 5 initials
   Next
   templateFile = Dir()
Wend

Let me look at the details of opening and saving Word templates and I should be able to write a macro.

 

[AppellatePerson]

The Dir() loop would be the outer loop, with nested loops for rows and columns. Pseudo-code something like this:

templateFile = Dir(templateFolder)
While templateFile <> ""
   For row = 2 to last row
       Open templateFile
       For column = 1 to last column
           Write cell value to bookmark with column heading
       Next
       Save template as new template with column 5 initials
   Next
   templateFile = Dir()
Wend

Let me look at the details of opening and saving Word templates and I should be able to write a macro.

Thank you so much, John. This is a huge help! I can't tell you how long I have been trying to cobble something together with no success.

 

[John_w]

Try this macro. Put the code in a standard module in your .xlsm Excel workbook.

You need to change 2 strings near the top of the code where indicated.

Option Explicit

Public Const wdTypeTemplate = 1
Public Const wdFormatXMLTemplate = 14

Public Sub Create_Word_Templates_From_Templates()

    Dim matchWordTemplates As String, WordTemplatesFolder As String
    Dim WordTemplateFileName As String
    Dim outputFolder As String
    Dim WordApp As Object 'Word.Application
    Dim TemplateDoc As Object 'Word.Document
    Dim WordAppOpened As Boolean
    Dim sheetData As Variant
    Dim r As Long, c As Long, i As Long
    Dim bookmarkName As String
    
    outputFolder = "C:\path\to\Output folder\" 'CHANGE THIS - destination folder for templates created by this macro
    
    matchWordTemplates = "C:\path\to\Word Templates\*.dotx"   'CHANGE THIS - folder containing the input templates and wildcard file spec
    
    'Get cell data from active sheet into 2-d array
    
    With ActiveSheet
        sheetData = .UsedRange.Value
    End With
    
    WordAppOpened = False
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If WordApp Is Nothing Then
        Set WordApp = CreateObject("Word.Application")
        'WordApp.Visible = True
        WordAppOpened = True
    End If
    
    WordTemplatesFolder = Left(matchWordTemplates, InStrRev(matchWordTemplates, "\"))
    
    'Loop through matching templates
    
    WordTemplateFileName = Dir(matchWordTemplates)
    While WordTemplateFileName <> vbNullString
    
        'Loop through array rows from row 2
        
        For r = 2 To UBound(sheetData)
        
            'Create a new template from this input template
            
            Set TemplateDoc = WordApp.Documents.Add(Template:=WordTemplatesFolder & WordTemplateFileName, NewTemplate:=True, DocumentType:=wdTypeTemplate)
            
            'Loop through array columns for this row
            
            For c = 1 To UBound(sheetData, 2)
                
                'Get bookmark name from column heading in row 1
                
                bookmarkName = Replace(Replace(Replace(Replace(sheetData(1, c), " ", "_"), ",", ""), "-", ""), ".", "")
     
                'Insert cell value at the bookmark and at bookmarks with same name and sequential number suffix
                
                i = 1
                While TemplateDoc.Bookmarks.Exists(bookmarkName)
                    TemplateDoc.Bookmarks(bookmarkName).Range.Text = sheetData(r, c)
                    bookmarkName = bookmarkName & "_" & i
                    i = i + 1
                Wend
            
            Next
            
            'Save the new template in the output folder with the initials
            
            TemplateDoc.SaveAs2 outputFolder & sheetData(r, 5) & " - " & WordTemplateFileName, FileFormat:=wdFormatXMLTemplate
            TemplateDoc.Close False
            
        Next
    
        'Get the next input template
        
        WordTemplateFileName = Dir
        
    Wend

    'Close Word if this macro opened it
    
    If WordAppOpened Then WordApp.Quit

    MsgBox "Done"

End Sub

 

[AppellatePerson]

Try this macro. Put the code in a standard module in your .xlsm Excel workbook.

You need to change 2 strings near the top of the code where indicated.

Option Explicit

Public Const wdTypeTemplate = 1
Public Const wdFormatXMLTemplate = 14

Public Sub Create_Word_Templates_From_Templates()

    Dim matchWordTemplates As String, WordTemplatesFolder As String
    Dim WordTemplateFileName As String
    Dim outputFolder As String
    Dim WordApp As Object 'Word.Application
    Dim TemplateDoc As Object 'Word.Document
    Dim WordAppOpened As Boolean
    Dim sheetData As Variant
    Dim r As Long, c As Long, i As Long
    Dim bookmarkName As String
   
    outputFolder = "C:\path\to\Output folder\" 'CHANGE THIS - destination folder for templates created by this macro
   
    matchWordTemplates = "C:\path\to\Word Templates\*.dotx"   'CHANGE THIS - folder containing the input templates and wildcard file spec
   
    'Get cell data from active sheet into 2-d array
   
    With ActiveSheet
        sheetData = .UsedRange.Value
    End With
   
    WordAppOpened = False
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If WordApp Is Nothing Then
        Set WordApp = CreateObject("Word.Application")
        'WordApp.Visible = True
        WordAppOpened = True
    End If
   
    WordTemplatesFolder = Left(matchWordTemplates, InStrRev(matchWordTemplates, "\"))
   
    'Loop through matching templates
   
    WordTemplateFileName = Dir(matchWordTemplates)
    While WordTemplateFileName <> vbNullString
   
        'Loop through array rows from row 2
       
        For r = 2 To UBound(sheetData)
       
            'Create a new template from this input template
           
            Set TemplateDoc = WordApp.Documents.Add(Template:=WordTemplatesFolder & WordTemplateFileName, NewTemplate:=True, DocumentType:=wdTypeTemplate)
           
            'Loop through array columns for this row
           
            For c = 1 To UBound(sheetData, 2)
               
                'Get bookmark name from column heading in row 1
               
                bookmarkName = Replace(Replace(Replace(Replace(sheetData(1, c), " ", "_"), ",", ""), "-", ""), ".", "")
    
                'Insert cell value at the bookmark and at bookmarks with same name and sequential number suffix
               
                i = 1
                While TemplateDoc.Bookmarks.Exists(bookmarkName)
                    TemplateDoc.Bookmarks(bookmarkName).Range.Text = sheetData(r, c)
                    bookmarkName = bookmarkName & "_" & i
                    i = i + 1
                Wend
           
            Next
           
            'Save the new template in the output folder with the initials
           
            TemplateDoc.SaveAs2 outputFolder & sheetData(r, 5) & " - " & WordTemplateFileName, FileFormat:=wdFormatXMLTemplate
            TemplateDoc.Close False
           
        Next
   
        'Get the next input template
       
        WordTemplateFileName = Dir
       
    Wend

    'Close Word if this macro opened it
   
    If WordAppOpened Then WordApp.Quit

    MsgBox "Done"

End Sub

Wow!!!! THIS IS SO CLOSE!!! It made all the output files, named them appropriately, and cycled through the templates. The only problem is that it replaced only the first instance of a bookmark type. So for example, if the employee's name was in the document 3 times, there were bookmarks named "Name_1", "Name_2," and "Name_3." The macro you wrote replaced only the bookmark for "Name_1" and the remaining instances showed up as the bookmark name.

 

[AppellatePerson]

Wow!!!! THIS IS SO CLOSE!!! It made all the output files, named them appropriately, and cycled through the templates. The only problem is that it replaced only the first instance of a bookmark type. So for example, if the employee's name was in the document 3 times, there were bookmarks named "Name_1", "Name_2," and "Name_3." The macro you wrote replaced only the bookmark for "Name_1" and the remaining instances showed up as the bookmark name.

This might be a problem with the bookmarks in the template. I'll double-check and report back.

 

[John_w]

The code uses the same bookmark naming convention as your code, which for the column heading "Name" would be "Name", "Name_1", "Name_2", etc.

However, I've found and fixed a bug with the sequential numbering logic, which meant the code would insert the cell value after bookmarks "Name" and "Name_1", if they exist, but not "Name_2".

If you're now saying the bookmarks are named "Name_1", "Name_2", etc. (not "Name") then I've modified the code accordingly.

Option Explicit

Public Const wdTypeTemplate = 1
Public Const wdFormatXMLTemplate = 14


Public Sub Create_Word_Templates_From_Templates()

    Dim matchWordTemplates As String, WordTemplatesFolder As String
    Dim WordTemplateFileName As String
    Dim outputFolder As String
    Dim WordApp As Object 'Word.Application
    Dim TemplateDoc As Object 'Word.Document
    Dim WordAppOpened As Boolean
    Dim sheetData As Variant
    Dim r As Long, c As Long, i As Long
    Dim bookmarkName As String
   
    outputFolder = "C:\path\to\Output folder\" 'CHANGE THIS - destination folder for templates created by this macro
   
    matchWordTemplates = "C:\path\to\Word Templates\*.dotx"   'CHANGE THIS - folder containing the input templates and wildcard file spec
       
    'Get cell data from active sheet into 2-d array
   
    With ActiveSheet
        sheetData = .UsedRange.Value
    End With
   
    WordAppOpened = False
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If WordApp Is Nothing Then
        Set WordApp = CreateObject("Word.Application")
        'WordApp.Visible = True
        WordAppOpened = True
    End If
   
    WordTemplatesFolder = Left(matchWordTemplates, InStrRev(matchWordTemplates, "\"))
   
    'Loop through matching templates
   
    WordTemplateFileName = Dir(matchWordTemplates)
    While WordTemplateFileName <> vbNullString
   
        'Loop through array rows from row 2
       
        For r = 2 To UBound(sheetData)
       
            'Create a new template from this input template
           
            Set TemplateDoc = WordApp.Documents.Add(Template:=WordTemplatesFolder & WordTemplateFileName, NewTemplate:=True, DocumentType:=wdTypeTemplate)
           
            'Loop through array columns for this row
           
            For c = 1 To UBound(sheetData, 2)
               
                'Get bookmark name from column heading in row 1
               
                bookmarkName = Replace(Replace(Replace(Replace(sheetData(1, c), " ", "_"), ",", ""), "-", ""), ".", "")
    
                'Insert cell value at bookmarks with same name and sequential number suffix
               
                i = 1
                While TemplateDoc.Bookmarks.Exists(bookmarkName & "_" & i)
                    TemplateDoc.Bookmarks(bookmarkName & "_" & i).Range.Text = sheetData(r, c)
                    i = i + 1
                Wend
           
            Next
           
            'Save the new template in the output folder with the initials
           
            TemplateDoc.SaveAs2 outputFolder & sheetData(r, 5) & " - " & WordTemplateFileName, FileFormat:=wdFormatXMLTemplate
            TemplateDoc.Close False
           
        Next
   
        'Get the next input template
       
        WordTemplateFileName = Dir
       
    Wend

    'Close Word if this macro opened it
   
    If WordAppOpened Then WordApp.Quit

    MsgBox "Done"

End Sub

 

[AppellatePerson]

The code uses the same bookmark naming convention as your code, which for the column heading "Name" would be "Name", "Name_1", "Name_2", etc.

However, I've found and fixed a bug with the sequential numbering logic, which meant the code would insert the cell value after bookmarks "Name" and "Name_1", if they exist, but not "Name_2".

If you're now saying the bookmarks are named "Name_1", "Name_2", etc. (not "Name") then I've modified the code accordingly.

Option Explicit

Public Const wdTypeTemplate = 1
Public Const wdFormatXMLTemplate = 14


Public Sub Create_Word_Templates_From_Templates()

    Dim matchWordTemplates As String, WordTemplatesFolder As String
    Dim WordTemplateFileName As String
    Dim outputFolder As String
    Dim WordApp As Object 'Word.Application
    Dim TemplateDoc As Object 'Word.Document
    Dim WordAppOpened As Boolean
    Dim sheetData As Variant
    Dim r As Long, c As Long, i As Long
    Dim bookmarkName As String
  
    outputFolder = "C:\path\to\Output folder\" 'CHANGE THIS - destination folder for templates created by this macro
  
    matchWordTemplates = "C:\path\to\Word Templates\*.dotx"   'CHANGE THIS - folder containing the input templates and wildcard file spec
      
    'Get cell data from active sheet into 2-d array
  
    With ActiveSheet
        sheetData = .UsedRange.Value
    End With
  
    WordAppOpened = False
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If WordApp Is Nothing Then
        Set WordApp = CreateObject("Word.Application")
        'WordApp.Visible = True
        WordAppOpened = True
    End If
  
    WordTemplatesFolder = Left(matchWordTemplates, InStrRev(matchWordTemplates, "\"))
  
    'Loop through matching templates
  
    WordTemplateFileName = Dir(matchWordTemplates)
    While WordTemplateFileName <> vbNullString
  
        'Loop through array rows from row 2
      
        For r = 2 To UBound(sheetData)
      
            'Create a new template from this input template
          
            Set TemplateDoc = WordApp.Documents.Add(Template:=WordTemplatesFolder & WordTemplateFileName, NewTemplate:=True, DocumentType:=wdTypeTemplate)
          
            'Loop through array columns for this row
          
            For c = 1 To UBound(sheetData, 2)
              
                'Get bookmark name from column heading in row 1
              
                bookmarkName = Replace(Replace(Replace(Replace(sheetData(1, c), " ", "_"), ",", ""), "-", ""), ".", "")
   
                'Insert cell value at bookmarks with same name and sequential number suffix
              
                i = 1
                While TemplateDoc.Bookmarks.Exists(bookmarkName & "_" & i)
                    TemplateDoc.Bookmarks(bookmarkName & "_" & i).Range.Text = sheetData(r, c)
                    i = i + 1
                Wend
          
            Next
          
            'Save the new template in the output folder with the initials
          
            TemplateDoc.SaveAs2 outputFolder & sheetData(r, 5) & " - " & WordTemplateFileName, FileFormat:=wdFormatXMLTemplate
            TemplateDoc.Close False
          
        Next
  
        'Get the next input template
      
        WordTemplateFileName = Dir
      
    Wend

    'Close Word if this macro opened it
  
    If WordAppOpened Then WordApp.Quit

    MsgBox "Done"

End Sub

Yep, that fixed the missed bookmark substitutions. Now it creates the output files and then when it gets done with the last entry it keeps trying to make more output files. After looping for awhile trying and failing to make more files, it throws an "invalid file" name bug. The most recent run through it said "Run-time error 5174: Sorry, we couldn't find your file. Was it moved, renamed, or deleted?" This is really weird because it made all the previous files just fine and I did not touch any of the templates or output files. When I click Debug it takes me to this part of the code:

For r = 2 To UBound(sheetData)
       
            'Create a new template from this input template
           
            Set TemplateDoc = WordApp.Documents.Add(Template:=WordTemplatesFolder & WordTemplateFileName, NewTemplate:=True, DocumentType:=wdTypeTemplate)

And it does not go on to the next template, obviously.

John, truly thank you so much. I know you do not have to help me and this internet stranger so appreciates it. I understand if you are done with this but I would love it if you are able to figure it out.