[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 377
  • Last Modified:

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


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
  • 2
1 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 :)




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

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

Paddy_Boy_FloydAuthor Commented:
Thank you very very much, this got me on the right track!
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.


Featured Post

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now