Populate Word Template From Excel Table, Save Each New File As Individual File

Posted on 2011-04-25
Last Modified: 2012-05-11

I have a Word 2007 file that contains a bunch of Active X textboxes and checkboxes, the "Template". I have an excel workbook that contains a table with client names and values that correspond to each textbox and checkbox on the word document. I would like to be able to click a command button in excel, and have Excel open one instance of word, populate the textboxes and checkboxes with the corresponding values from excel, save the word file in a new folder on the user's desktop, and the proceed to create a new word document and do the same thing all the way down the list. Please refer to the attached files. The crappy code I have been able to write so far is located in the Excel file. Thanks for your help. 2011-04-19-Group-Notes-Automatio.xlsm Group-Note-Template-Auto-Backup-.docx
Question by:Paddy_Boy_Floyd
    LVL 30

    Accepted Solution

    Whoa! That is lot of code for a simple operation like this :)

    Ok do this. make a copy of your above excel file and then delete all the code in it. Insert a module and paste this code.

    In the code below, I have shown you on how to populate 1st 3 fields. Just add code below it for the rest of the fields. I have commented the code so that it is easier to understand.

    Also you may call Sub OpenWordAndPopulate() from the Private Sub CommandButton1_Click() like this

    Private Sub CommandButton1_Click()
    End Sub

    Open in new window

    Let me know if you face any problems :)



    MAIN Code

    Option Explicit
    '~~> Path of the main word file
    Const docFile As String = "C:\Sample\Group-Note-Template-Auto-Backup.Docx"
    '~~> This is where the new files will be saved
    Const OutputPath As String = "C:\Sample\"
    Sub OpenWordAndPopulate()
        Dim appWD As Object, wdDoc As Object
        Dim ws As Worksheet
        Dim lastRow As Long, i As Long
        Set ws = Sheets("Input")
        lastRow = ws.Range("F" & Rows.Count).End(xlUp).Row
        If lastRow < 6 Then Exit Sub
        On Error Resume Next
        Set appWD = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
             '~~> Could not get instance, so create a new one
            Set appWD = CreateObject("Word.Application")
        End If
        On Error GoTo 0
        '~~> Loop Through Excel cells and populate the fields
        For i = 6 To lastRow
            Set wdDoc = appWD.Documents.Open(docFile)
            wdDoc.tbGroupName.Value = ws.Range("D" & i).Value
            wdDoc.tbGroupDate.Value = ws.Range("C" & i).Value
            wdDoc.tbClientName.Value = ws.Range("A" & i).Value
            '~~> Insert code here for the Rest of the fields
            '~~> Save the file. I am using this format "ClientName - Client ID.Docx"
            wdDoc.SaveAs OutputPath & ws.Range("A" & i).Value & "-" & ws.Range("B" & i).Value & ".Docx"
            wdDoc.Close savechanges:=False
        '~~> Clean Up
        Set wdDoc = Nothing
        Set appWD = Nothing
        MsgBox "Done"
    End Sub

    Open in new window

    LVL 76

    Expert Comment

    It would make it easier if the header names matched the control names.

    However this looks like a candidate for mail merge which does not require any coding, so, if you were starting from scratch, I would definitely recommend that option.

    In case you want to pursue it with this project, here is some code that replaces the each control with a merge field named after the label (or control caption) in the table cell.

    Sub MakeMailMergeMainDoc()
        Dim ilsh As InlineShape
        Dim rng As Range
        Dim cl As Cell
        Dim strText As String
        Set ilsh = ActiveDocument.InlineShapes(1)
        Do Until ilsh Is Nothing
        If ilsh.Type = wdInlineShapeOLEControlObject Then
            Set rng = ilsh.Range
            If rng.Tables.Count = 1 Then
                If ilsh.OLEFormat.ClassType = "Forms.CheckBox.1" Then
                    strText = ilsh.OLEFormat.Object.Caption
                    rng.Text = strText
                    rng.Collapse wdCollapseEnd
                    strText = GetCellText(rng.Cells(1))
                End If
                ActiveDocument.Fields.Add rng, wdFieldMergeField, Replace(Replace(strText, ":", ""), " ", "_")
                Exit Do
            End If
        End If
        Set ilsh = ActiveDocument.InlineShapes(1)
    End Sub
    Function GetCellText(cl As Cell) As String
        Dim rng As Range
        Set rng = cl.Range
        rng.MoveEnd wdCharacter, -1 'drop cell formatting
        GetCellText = rng.Text
    End Function

    Open in new window


    Author Closing Comment

    Thank you very very much, this got me on the right track!
    LVL 30

    Expert Comment

    Paddy_Boy_Floyd: You rated a "B" to my post. Was it lacking something? The reason why I am asking is because I took time to write that code and test it and it is working just fine.


    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    How your wiki can always stay up-to-date

    Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
    - Increase transparency
    - Onboard new hires faster
    - Access from mobile/offline

    This article describes how to use the Send to Mail Recipient command. The instructions apply generally to Office 2007 and later versions, but Microsoft® Word 2013 was used for the specific steps and figures.  What is Send to Mail Recipient? Send…
    This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
    This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
    This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

    761 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    9 Experts available now in Live!

    Get 1:1 Help Now