自动化从 Excel 填充 Word 模板的过程所需的帮助

Question

我是 VBA 的完全新手，如果有人愿意的话，我非常感谢一些自动化流程的帮助。 :)

我正在尝试从我创建的 Excel 电子表格中填充 Word 模板

我找到了一些代码可以让我打开我的 Word 模板，但这是我能做的 :(lol

Private Sub PrintHDR_Click()

Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

objWord.Documents.Open "C:\Users\Duncan\Desktop\HDR.dotx"

End Sub

我希望实现的下一步是将某些单元格中的数据复制并粘贴到我的 Word 文档中。

我已经在 Word 中设置了书签并命名了要复制的单元格。

一些单元格包含文本，其他单元格包含产生数字答案的公式/总和。在包含公式或总和的单元格中，这是我要复制到 Word 中的答案。

任何帮助将不胜感激。

提前致谢:)

邓肯

Answer 1

我有这样的代码。在 Word 中，我不使用书签来替换要替换的字段，而是使用特殊标记（如 <<NAME>>）。

您可能需要适应。我使用 ListObject（新的 Excel“表格”），如果您使用简单的 Range，则可以更改它。

创建一个“Template.docx”文档，将其设为只读，并将可替换字段放在那里（<<NAME>> 等）。一个简单的 docx 就可以了，它不必是一个真正的模板（dotx）。

Public Sub WriteToTemplate()
    Const colNum = 1
    Const colName = 2
    Const colField2 = 3
    Const cBasePath = "c:\SomeDir"

    Dim wordDoc As Object, sFile As String, Name As String
    Dim lo As ListObject, theRow As ListRow
    Dim item As tItem

    Set lo = ActiveCell.ListObject
    Set theRow = ActiveCell.ListObject.ListRows(ActiveCell.Row - lo.Range.Row)
    With theRow.Range
        'I use one of the columns for the filename:
        Debug.Print "writing " & theRow.Range.Cells(1, colName).text

        'A filename cannot contain any of the following characters:     \ / : * ? " < > |
        Name = Replace(.Cells(1, colName), "?", "")
        Name = Replace(Name, "*", "")
        Name = Replace(Name, "/", "-")
        Name = Replace(Name, ":", ";")
        Name = Replace(Name, """", "'")

        sFile = (cBasePath & "\" & Name) & ".docx"
        Debug.Print sFile

        Set wordApp = CreateObject("word.Application")

        If Dir(sFile) <> "" Then 'file already exists
            Set wordDoc = wordApp.Documents.Open(sFile)
            wordApp.Visible = True
            wordApp.Activate
        Else 'new file
            Set wordDoc = wordApp.Documents.Open(cBasePath & "\" & "Template.docx")
            wordApp.Selection.Find.Execute Forward:=(wordApp.Selection.Start = 0), FindText:="««NUM»»", ReplaceWith:=.Cells(1, colNum)

            wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
            wordApp.Selection.Find.Execute FindText:="««NAME»»", ReplaceWith:=.Cells(1, colName)

            wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
            wordApp.Selection.Find.Execute FindText:="««FIELD2»»", ReplaceWith:=.Cells(1, colField2)

            wordDoc.ListParagraphs.item(1).Range.Select
            wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
            wordApp.Visible = True
            wordApp.Activate
            On Error Resume Next
            'if this fails (missing directory, for example), file will be unsaved, and Word will ask for name.
            wordDoc.SaveAs sFile 'Filename:=(cBasePath & "\" & .Cells(1, colName))
            On Error GoTo 0
        End If
    End With
End Sub

这基本上复制了代码中的邮件合并功能，让您有更多的控制权。