从 Excel 复制数据以填充到带书签的 Word 模板中

Question

我有一组Excel数据库，想通过VBA将它们复制到带书签的Word模板中。将生成单独的 Word 文档。

编码请如下

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

现在，我想生成一个多页的Word文档。如何修改编码生成一个多页的word文档？

Answer 1

微软文档：

Selection.InsertBreak 方法（Word）

Selection.EndKey 方法（Word）

Selection.WholeStory 方法（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

---

更新：

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
        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
    For Each oBM In doc.Bookmarks
        oBM.Delete
    Next
End Sub