Copy Data from Excel to fill into Word Templates with Bookmarks

Question

I have a set of database in Excel and want to copy them into a Word template with bookmarks through VBA. Individual Word Documents will be generated.

Coding please find as below

Option Explicit

'change this to where your files are stored
Const FilePath As String = "C:\Users\User\Desktop\"
Dim wd As New Word.Application
Dim PersonCell As Range

Sub CreateWordDocuments()
  'create copy of Word in memory
  Dim doc As Word.Document
  wd.Visible = True

  Dim PersonRange As Range
  'create a reference to all the people
  Range("A4").Select

  Set PersonRange = Range(ActiveCell, ActiveCell.End(xlDown))

  'for each person in list
  For Each PersonCell In PersonRange
    'open a document in Word
    Set doc = wd.Documents.Open(FilePath & "Template.docx")
      
    'go to each bookmark and type in details
    CopyCell "FirstName", 1
    CopyCell "LastName", 2
    CopyCell "Company", 3
    CopyCell "Address", 4

    'save and close this document
    doc.SaveAs2 FilePath & "person " & PersonCell.Value & " (" & Format(Now, "yyyy-mm-dd") & ").docx"
    doc.Close
  Next PersonCell

  wd.Quit

  MsgBox "Created files in " & FilePath & "!"

  Set doc = Nothing
  Set wd = Nothing
End Sub

Sub CopyCell(BookMarkName As String, ColumnOffset As Integer)
  'copy each cell to relevant Word bookmark
  wd.Selection.GoTo What:=wdGoToBookmark, Name:=BookMarkName
  wd.Selection.TypeText PersonCell.Offset(0, ColumnOffset).Value
End Sub

Now, I want to generate one Word document with multiple pages. How to modify the coding to generate one word document with multiple pages?

Answer 1

Microsoft documentation:

Selection.InsertBreak method (Word)

Selection.EndKey method (Word)

Selection.WholeStory method (Word)

Option Explicit
Sub CreateWordDocuments()
    Dim wd As New Word.Application
    '    Dim wd As Word.Application
    Dim PersonCell As Range
    Dim doc As Word.Document
    'change this to where your files are stored
    Const FilePath As String = "D:\temp\"
    '    Set wd = GetObject(, "word.application") ' for testing
    wd.Visible = True
    Dim PersonRange As Range
    'create a reference to all the people
    Set PersonRange = Range(Range("A4"), Range("A4").End(xlDown))
    Set doc = wd.Documents.Open(FilePath & "Template.docx")
    ' Copy the contents of template doc
    wd.Selection.WholeStory
    wd.Selection.Copy
    wd.Selection.Delete
    'for each person in list
    For Each PersonCell In PersonRange
        'paste the template at the end of doc
        wd.Selection.EndKey Unit:=wdStory
        If wd.Selection.End > 0 Then
            wd.Selection.InsertBreak Type:=wdPageBreak
        End If
        wd.Selection.Paste
        'go to each bookmark and type in details
        CopyCell "FirstName", 1, PersonCell, wd
        CopyCell "LastName", 2, PersonCell, wd
        CopyCell "Company", 3, PersonCell, wd
        CopyCell "Address", 4, PersonCell, wd
    Next PersonCell
    'save and close this document
    doc.SaveAs2 FilePath & "person(" & Format(Now, "yyyy-mm-dd") & ").docx"
    doc.Close
    wd.Quit
    MsgBox "Created files in " & FilePath & "!"
    Set doc = Nothing
    Set wd = Nothing
End Sub
Sub CopyCell(ByVal BookMarkName As String, ByVal ColumnOffset As Integer, ByVal PersonCell As Range, wd As Word.Application)
    'copy each cell to relevant Word bookmark
    wd.Selection.GoTo What:=wdGoToBookmark, Name:=BookMarkName
    wd.Selection.TypeText PersonCell.Offset(0, ColumnOffset).Value
End Sub

---

Update:

Option Explicit
Sub CreateWordDocuments()
    Dim wd As New Word.Application
    '    Dim wd As Word.Application
    Dim PersonCell As Range
    Dim doc As Word.Document
    'change this to where your files are stored
    Const FilePath As String = "D:\temp\"
    '    Set wd = GetObject(, "word.application") ' for testing
    wd.Visible = True
    Dim PersonRange As Range
    'create a reference to all the people
    With Sheets("Sheet1") ' ** '
        Set PersonRange = .Range("A4", .Range("A4").End(xlDown)) ' ** '
    End With ' ** '
    Set doc = wd.Documents.Open(FilePath & "Template.docx")
    ' Copy the contents of template doc
    wd.Selection.WholeStory
    wd.Selection.Copy
    wd.Selection.Delete
    'for each person in list
    For Each PersonCell In PersonRange
        'paste the template at the end of doc
        wd.Selection.EndKey Unit:=wdStory
        If wd.Selection.End > 0 Then
            wd.Selection.InsertBreak Type:=wdPageBreak
        End If
        wd.Selection.Paste
        'go to each bookmark and type in details
        CopyCell "FirstName", 1, PersonCell, wd
        CopyCell "LastName", 2, PersonCell, wd
        CopyCell "Company", 3, PersonCell, wd
        CopyCell "Address", 4, PersonCell, wd
        Call RemoveBMs(doc)
    Next PersonCell
    'save and close this document
    doc.SaveAs2 FilePath & "person(" & Format(Now, "yyyy-mm-dd") & ").docx"
    doc.Close
    wd.Quit
    MsgBox "Created files in " & FilePath & "!"
    Set doc = Nothing
    Set wd = Nothing
End Sub
Sub CopyCell(ByVal BookMarkName As String, ByVal ColumnOffset As Integer, ByVal PersonCell As Range, wd As Word.Application)
    'copy each cell to relevant Word bookmark
    wd.Selection.GoTo What:=wdGoToBookmark, Name:=BookMarkName
    wd.Selection.TypeText PersonCell.Offset(0, ColumnOffset).Value
End Sub
Sub RemoveBMs(doc As Word.Document)
    Dim oBM As Bookmark
    Const BM_NAME = "FirstName|LastName|Company|Address"
    For Each oBM In doc.Bookmarks
        If InStr(1, BM_NAME, oBM.Name, vbTextCompare) > 0 Then _
        oBM.Delete
    Next
End Sub