从一系列文档模板生成 Word 文档（在 Excel VBA 中）答案

【问题标题】：Generate Word Documents (in Excel VBA) from a series of Document Templates从一系列文档模板生成 Word 文档（在 Excel VBA 中）
【发布时间】：2020-04-09 00:21:16
【问题描述】：

大家好。我会尽量使这个简短而简单。 :)

我有

40 个左右的样板 word 文档，其中包含需要填写的一系列字段（姓名、地址等）。这在过去是手动完成的，但重复且繁琐。
用户填写了大量个人信息的工作簿。

我需要

一种以编程方式（从 Excel VBA）打开这些样板文档、编辑工作簿中各种命名范围的字段值并将填写的模板保存到本地文件夹的方法。

如果我使用 VBA 以编程方式编辑一组电子表格中的特定值，我会编辑所有这些电子表格以包含一组可在自动填充过程中使用的命名范围，但我不知道Word 文档中的任何“命名字段”功能。

如何编辑文档并创建 VBA 例程，以便打开每个文档、查找可能需要填写的一组字段并替换一个值？

例如，像这样工作的东西：

for each document in set_of_templates
    if document.FieldExists("Name") then document.Field("Name").value = strName
    if document.FieldExists("Address") then document.Field("Name").value = strAddress
    ...

    document.saveAs( thisWorkbook.Path & "\GeneratedDocs\ " & document.Name )
next document

我考虑过的事情：

邮件合并 - 但这还不够，因为它需要手动打开每个文档并将工作簿构建为数据源，我有点想要相反的结果。模板是数据源，工作簿正在遍历它们。此外，邮件合并用于使用不同数据表创建许多相同的文档。我有许多文档都使用相同的数据。
使用“#NAME#”等占位符文本并打开每个文档进行搜索和替换。如果没有更优雅的建议，这就是我会采用的解决方案。

【问题讨论】：

MailMerge 不适合有什么原因吗？
嘿 Remou，来自 OP - 我发现这种方法不够用，因为它需要手动打开每个文档并将工作簿构建为数据源，我有点想要相反的结果。模板是数据源，工作簿正在遍历它们。此外，邮件合并用于使用不同数据表创建许多相同的文档。我有很多文档都使用相同的数据。
Mailmerge 可以从 VBA 运行，即可以从 VBA 设置数据源，并且可以有任意数量的记录。我认为这会比通过不确定数量的字段更容易，并且需要更少的代码。
我认为您可能从错误的方向看待 Mailmerge。它完全按照您的意愿工作，Excel 保存要填充到 Word 字段中的数据。
一种方法是使用 Word 文档中的书签和代码以及 Excel 中的命名范围和代码。要做到这一点，请获取一份专业 Excel 开发的副本，其中有一个非常好的示例，我不止一次使用过。我刚刚尝试在网上搜索，但只找到了 sn-ps，如果您要继续做这种事情，PED 是一本很棒的书。

标签： excel ms-word documentation-generation vba

【解决方案1】：

我已经很久没有问这个问题了，我的解决方案也经历了越来越多的细化。我不得不处理各种特殊情况，例如直接来自工作簿的值、需要根据列表专门生成的部分以及需要在页眉和页脚中进行替换。

事实证明，使用书签是不够的，因为用户可以稍后编辑文档以更改、添加和删除文档中的占位符值。解决方案实际上是使用 关键字，例如：

这只是示例文档中的一个页面，它使用了一些可以自动插入到文档中的可能值。存在超过 50 个文档，它们具有完全不同的结构和布局，并使用不同的参数。 word 文档和 excel 电子表格共享的唯一共同知识是了解这些占位符值的含义。在 excel 中，这是存储在文档生成关键字列表中，其中包含关键字，后跟对实际包含该值的范围的引用：

这是所需的两个关键成分。现在有了一些聪明的代码，我所要做的就是遍历要生成的每个文档，然后遍历所有已知关键字的范围，然后对每个文档中的每个关键字进行搜索和替换。

首先，我有 wrapper 方法，它负责维护一个 microsoft word 实例，迭代所有选择生成的文档，为文档编号，并执行用户界面操作（如处理错误，向用户显示文件夹等）

' Purpose: Iterates over and generates all documents in the list of forms to generate
'          Improves speed by creating a persistant Word application used for all generated documents
Public Sub GeneratePolicy()
    Dim oWrd As New Word.Application
    Dim srcPath As String
    Dim cel As Range

    If ERROR_HANDLING Then On Error GoTo errmsg
    If Forms.Cells(2, FormsToGenerateCol) = vbNullString Then _
        Err.Raise 1, , "There are no forms selected for document generation."
    'Get the path of the document repository where the forms will be found.
    srcPath = FindConstant("Document Repository")
    'Each form generated will be numbered sequentially by calling a static counter function. This resets it.
    GetNextEndorsementNumber reset:=True
    'Iterate over each form, calling a function to replace the keywords and save a copy to the output folder
    For Each cel In Forms.Range(Forms.Cells(2, FormsToGenerateCol), Forms.Cells(1, FormsToGenerateCol).End(xlDown))
        RunReplacements cel.value, CreateDocGenPath(cel.Offset(0, 1).value), oWrd
    Next cel
    oWrd.Quit
    On Error Resume Next
    'Display the folder containing the generated documents
    Call Shell("explorer.exe " & CreateDocGenPath, vbNormalFocus)
    oWrd.Quit False
    Application.StatusBar = False
    If MsgBox("Policy generation complete. The reserving information will now be recorded.", vbOKCancel, _
              "Policy Generated. OK to store reserving info?") = vbOK Then Push_Reserving_Requirements
    Exit Sub
errmsg:
    MsgBox Err.Description, , "Error generating Policy Documents"
End Sub

该例程调用RunReplacements，它负责打开文档、为快速替换准备环境、完成后更新链接、处理错误等：

' Purpose: Opens up a document and replaces all instances of special keywords with their respective values.
'          Creates an instance of Word if an existing one is not passed as a parameter.
'          Saves a document to the target path once the template has been filled in.
'
'          Replacements are done using two helper functions, one for doing simple keyword replacements,
'          and one for the more complex replacements like conditional statements and schedules.
Private Sub RunReplacements(ByVal DocumentPath As String, ByVal SaveAsPath As String, _
                            Optional ByRef oWrd As Word.Application = Nothing)
    Dim oDoc As Word.Document
    Dim oWrdGiven As Boolean
    If oWrd Is Nothing Then Set oWrd = New Word.Application Else oWrdGiven = True

    If ERROR_HANDLING Then On Error GoTo docGenError
    oWrd.Visible = False
    oWrd.DisplayAlerts = wdAlertsNone

    Application.StatusBar = "Opening " & Mid(DocumentPath, InStrRev(DocumentPath, "\") + 1)
    Set oDoc = oWrd.Documents.Open(Filename:=DocumentPath, Visible:=False)
    RunAdvancedReplacements oDoc
    RunSimpleReplacements oDoc
    UpdateLinks oDoc 'Routine which will update calculated statements in Word (like current date)
    Application.StatusBar = "Saving " & Mid(DocumentPath, InStrRev(DocumentPath, "\") + 1)
    oDoc.SaveAs SaveAsPath

    GoTo Finally
docGenError:
    MsgBox "Un unknown error occurred while generating document: " & DocumentPath & vbNewLine _
            & vbNewLine & Err.Description, vbCritical, "Document Generation"
Finally:
    If Not oDoc Is Nothing Then oDoc.Close False: Set oDoc = Nothing
    If Not oWrdGiven Then oWrd.Quit False
End Sub

然后该例程调用RunSimpleReplacements。和RunAdvancedReplacements。在前者中，我们遍历文档生成关键字集，如果文档包含我们的关键字，则调用WordDocReplace。请注意，尝试和Find 一堆词找出它们不存在，然后不加选择地调用替换要快得多，因此我们总是在尝试替换之前检查关键字是否存在。

' Purpose: While short, this short module does most of the work with the help of the generation keywords
'          range on the lists sheet. It loops through every simple keyword that might appear in a document
'          and calls a function to have it replaced with the corresponding data from pricing.
Private Sub RunSimpleReplacements(ByRef oDoc As Word.Document)
    Dim DocGenKeys As Range, valueSrc As Range
    Dim value As String
    Dim i As Integer

    Set DocGenKeys = Lists.Range("DocumentGenerationKeywords")
    For i = 1 To DocGenKeys.Rows.Count
        If WordDocContains(oDoc, "#" & DocGenKeys.Cells(i, 1).Text & "#") Then
            'Find the text that we will be replacing the placeholder keyword with
            Set valueSrc = Range(Mid(DocGenKeys.Cells(i, 2).Formula, 2))
            If valueSrc.MergeCells Then value = valueSrc.MergeArea.Cells(1, 1).Text Else value = valueSrc.Text
            'Perform the replacement
            WordDocReplace oDoc, "#" & DocGenKeys.Cells(i, 1).Text & "#", value
        End If
    Next i
End Sub

这是用于检测文档中是否存在关键字的函数：

' Purpose: Function called for each replacement to first determine as quickly as possible whether
'          the document contains the keyword, and thus whether replacement actions must be taken.
Public Function WordDocContains(ByRef oDoc As Word.Document, ByVal searchFor As String) As Boolean
    Application.StatusBar = "Checking for keyword: " & searchFor
    WordDocContains = False
    Dim storyRange As Word.Range
    For Each storyRange In oDoc.StoryRanges
        With storyRange.Find
            .Text = searchFor
            WordDocContains = WordDocContains Or .Execute
        End With
        If WordDocContains Then Exit For
    Next
End Function

这就是橡胶与道路相遇的地方 - 执行替换的代码。当我遇到困难时，这个程序变得更加复杂。以下是您只能从经验中吸取的教训：

您可以直接设置替换文本，也可以使用剪贴板。我发现如果您使用超过 255 个字符的字符串在 word 中进行 VBA 替换，如果您尝试将其放在 Find.Replacement.Text 中，文本将被截断，但您可以使用 "^c" 作为您的替换文本，它将直接从剪贴板中获取。这是我必须使用的解决方法。
仅调用 replace 会丢失某些文本区域（如页眉和页脚）中的关键字。因此，您实际上需要遍历 document.StoryRanges 并在每个上运行搜索和替换，以确保您捕获要替换的单词的所有实例。

这就解释了一切。评论也应该很清楚。这是执行魔法的黄金程序：

' Purpose: This function actually performs replacements using the Microsoft Word API
Public Sub WordDocReplace(ByRef oDoc As Word.Document, ByVal replaceMe As String, ByVal replaceWith As String)
    Dim clipBoard As New MSForms.DataObject
    Dim storyRange As Word.Range
    Dim tooLong As Boolean

    Application.StatusBar = "Replacing instances of keyword: " & replaceMe

    'We want to use regular search and replace if we can. It's faster and preserves the formatting that
    'the keyword being replaced held (like bold).  If the string is longer than 255 chars though, the
    'standard replace method doesn't work, and so we must use the clipboard method (^c special character),
    'which does not preserve formatting. This is alright for schedules though, which are always plain text.
    If Len(replaceWith) > 255 Then tooLong = True
    If tooLong Then
        clipBoard.SetText IIf(replaceWith = vbNullString, "", replaceWith)
        clipBoard.PutInClipboard
    Else
        'Convert excel in-cell line breaks to word line breaks. (Not necessary if using clipboard)
        replaceWith = Replace(replaceWith, vbNewLine, vbCr)
        replaceWith = Replace(replaceWith, Chr(10), vbCr)
    End If
    'Replacement must be done on multiple 'StoryRanges'. Unfortunately, simply calling replace will miss
    'keywords in some text areas like headers and footers.
    For Each storyRange In oDoc.StoryRanges
        Do
            With storyRange.Find
                .MatchWildcards = True
                .Text = replaceMe
                .Replacement.Text = IIf(tooLong, "^c", replaceWith)
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
            On Error Resume Next
            Set storyRange = storyRange.NextStoryRange
            On Error GoTo 0
        Loop While Not storyRange Is Nothing
    Next
    If tooLong Then clipBoard.SetText ""
    If tooLong Then clipBoard.PutInClipboard
End Sub

当一切尘埃落定时，我们会得到一个漂亮的初始文档版本，其中包含生产值来代替那些带有哈希标记的关键字。我很想举一个例子，但当然每个填写的文档都包含所有专有信息。

我想唯一可以提及的就是RunAdvancedReplacements 部分。它做了一些非常相似的事情——它最终调用了相同的 WordDocReplace 函数，但这里使用的关键字的特殊之处在于它们不链接到原始工作簿中的单个单元格，它们是在代码隐藏中生成的工作簿中的列表。例如，其中一种高级替换如下所示：

'Generate the schedule of vessels
If WordDocContains(oDoc, "#VESSELSCHEDULE#") Then _
    WordDocReplace oDoc, "#VESSELSCHEDULE#", GenerateVesselSchedule()

然后会有一个相应的例程将包含用户配置的所有船只信息的字符串放在一起：

' Purpose: Generates the list of vessels from the "Vessels" sheet based on the user's configuration
'          in the booking tab. The user has the option to generate one or both of Owned Vessels
'          and Chartered Vessels, as well as what fields to display. Uses a helper function.
Public Function GenerateVesselSchedule() As String
    Dim value As String

    Application.StatusBar = "Generating Schedule of Vessels."
    If Booking.Range("ListVessels").value = "Yes" Then
        Dim VesselCount As Long

        If Booking.Range("ListVessels").Offset(1).value = "Yes" Then _
            value = value & GenerateVesselScheduleHelper("Vessels", VesselCount)
        If Booking.Range("ListVessels").Offset(1).value = "Yes" And _
           Booking.Range("ListVessels").Offset(2).value = "Yes" Then _
            value = value & "(Chartered Vessels)" & vbNewLine
        If Booking.Range("ListVessels").Offset(2).value = "Yes" Then _
            value = value & GenerateVesselScheduleHelper("CharteredVessels", VesselCount)
        If Len(value) > 2 Then value = Left(value, Len(value) - 2) 'Remove the trailing line break
    Else
        GenerateVesselSchedule = Booking.Range("VesselSchedAlternateText").Text
    End If
    GenerateVesselSchedule = value
End Function

' Purpose: Helper function for the Vessel Schedule generation routine. Generates either the Owned or
'          Chartered vessels based on the schedule parameter passed. The list is numbered and contains
'          the information selected by the user on the Booking sheet.
' SENSITIVE: Note that this routine is sensitive to the layout of the Vessel Schedule tab and the
'            parameters on the Configure Quotes tab. If either changes, it should be revisited.
Public Function GenerateVesselScheduleHelper(ByVal schedule As String, ByRef VesselCount As Long) As String
    Dim value As String, nextline As String
    Dim numInfo As Long, iRow As Long, iCol As Long
    Dim Inclusions() As Boolean, Columns() As Long

    'Gather info about vessel info to display in the schedule
    With Booking.Range("VesselInfoToInclude")
        numInfo = Booking.Range(.Cells(1, 1), .End(xlToRight)).Columns.Count - 1
        ReDim Inclusions(1 To numInfo)
        ReDim Columns(1 To numInfo)
        On Error Resume Next 'Some columns won't be identified
        For iCol = 1 To numInfo
            Inclusions(iCol) = .Offset(0, iCol) = "Yes"
            Columns(iCol) = sumSchedVessels.Range(schedule).Cells(1).EntireRow.Find(.Offset(-1, iCol)).Column
        Next iCol
        On Error GoTo 0
    End With

    'Build the schedule
    With sumSchedVessels.Range(schedule)
        For iRow = .row + 1 To .row + .Rows.Count - 1
            If Len(sumSchedVessels.Cells(iRow, Columns(1)).value) > 0 Then
                VesselCount = VesselCount + 1
                value = value & VesselCount & "." & vbTab
                nextline = vbNullString
                'Add each property that was included to the description string
                If Inclusions(1) Then nextline = nextline & sumSchedVessels.Cells(iRow, Columns(1)) & vbTab
                If Inclusions(2) Then nextline = nextline & "Built: " & sumSchedVessels.Cells(iRow, Columns(2)) & vbTab
                If Inclusions(3) Then nextline = nextline & "Length: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(3)), "#'") & vbTab
                If Inclusions(4) Then nextline = nextline & "" & sumSchedVessels.Cells(iRow, Columns(4)) & vbTab
                If Inclusions(5) Then nextline = nextline & "Hull Value: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(5)), "$#,##0") & vbTab
                If Inclusions(6) Then nextline = nextline & "IV: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(6)), "$#,##0") & vbTab
                If Inclusions(7) Then nextline = nextline & "TIV: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(7)), "$#,##0") & vbTab
                If Inclusions(8) And schedule = "CharteredVessels" Then _
                    nextline = nextline & "Deductible: " & Format(bmCharterers.Range(schedule).Cells( _
                               iRow - .row, 9), "$#,##0") & vbTab
                nextline = Left(nextline, Len(nextline) - 1) 'Remove the trailing tab
                'If more than 4 properties were included insert a new line after the 4th one
                Dim tabloc As Long: tabloc = 0
                Dim counter As Long: counter = 0
                Do
                    tabloc = tabloc + 1
                    tabloc = InStr(tabloc, nextline, vbTab)
                    If tabloc > 0 Then counter = counter + 1
                Loop While tabloc > 0 And counter < 4
                If counter = 4 Then nextline = Left(nextline, tabloc - 1) & vbNewLine & Mid(nextline, tabloc)
                value = value & nextline & vbNewLine
            End If
        Next iRow
    End With

    GenerateVesselScheduleHelper = value
End Function

生成的字符串可以像任何 excel 单元格的内容一样使用，并传递给替换函数，如果超过 255 个字符，它将适当地使用剪贴板方法。

所以这个模板：

加上这个电子表格数据：

变成这个文件：

我真诚地希望有一天这对某人有所帮助。这绝对是一项艰巨的任务，需要重新发明一个复杂的轮子。该应用程序非常庞大，有超过 50,000 行 VBA 代码，所以如果我在代码中的某个地方引用了某人需要的关键方法，请留下评论，我会在此处添加。

【讨论】：

这太棒了！我无法形容你如此详细地发布了这个答案，我有多高兴。
出色的答案做得很好，但在我工作的地方，我们构建了一个应用程序，每天在 vb.net 中为数百个字母执行此操作，从 SQL Server 获取数据......
在我们的 .NET 版本中，我们使用 { 和 } 作为将被替换的字段周围的占位符...

【解决方案2】：

http://www.computorcompanion.com/LPMArticle.asp?ID=224 描述 Word 书签的使用

文档中的一段文本可以被添加书签，并被赋予一个变量名。使用 VBA，可以访问此变量，并且可以将文档中的内容替换为替代内容。这是在文档中使用名称和地址等占位符的解决方案。

此外，使用书签，可以修改文档以引用带书签的文本。如果一个名称在整个文档中多次出现，则可以为第一个实例添加书签，并且其他实例可以引用该书签。现在，当第一个实例以编程方式更改时，整个文档中变量的所有其他实例也会自动更改。

现在所需要做的就是通过为占位符文本添加书签并在整个文档中使用一致的命名约定来更新所有文档，然后遍历每个文档以替换书签（如果存在）：

document.Bookmarks("myBookmark").Range.Text = "Inserted Text"

在尝试每次替换之前，我可能可以使用 on error resume next 子句解决未出现在给定文档中的变量问题。

感谢Doug Glancy 在他的评论中提到书签的存在。我事先并不知道他们的存在。我将继续发布这个主题，说明这个解决方案是否足够。

【讨论】：

【解决方案3】：

您可以考虑使用基于 XML 的方法。

Word 具有称为自定义 XML 数据绑定或数据绑定内容控件的功能。内容控件本质上是文档中可以包含内容的一个点。 “数据绑定”内容控件从您包含在 docx zip 文件中的 XML 文档中获取其内容。 XPath 表达式用于说明 XML 的哪个位。因此，您需要做的就是包含您的 XML 文件，其余的由 Word 完成。

Excel 有办法以 XML 格式从中获取数据，因此整个解决方案应该可以很好地工作。

在 MSDN 上有大量关于内容控制数据绑定的信息（其中一些已在早期的 SO 问题中引用过），因此我不会费心在此处包含它们。

但您确实需要一种设置绑定的方法。您可以使用 Content Control Toolkit，或者如果您想在 Word（我的 OpenDoPE 插件）中执行此操作。

【讨论】：

这将是一个非常简洁的方法，因为它不需要打开 word 文件或使用 office interop 来获取内容。我会朝那个方向做一些研究。

【解决方案4】：

完成类似任务后，我发现将值插入表比搜索命名标签要快得多 - 然后可以像这样插入数据：

    With oDoc.Tables(5)
    For i = 0 To Data.InvoiceDictionary.Count - 1
        If i > 0 Then
            oDoc.Tables(5).rows.Add
        End If
         Set invoice = Data.InvoiceDictionary.Items(i)
        .Cell(i + 2, 1).Range.Text = invoice.InvoiceCCNumber
        .Cell(i + 2, 2).Range.Text = invoice.InvoiceDate
        .Cell(i + 2, 3).Range.Text = invoice.TransactionType
        .Cell(i + 2, 4).Range.Text = invoice.Description
        .Cell(i + 2, 5).Range.Text = invoice.SumOfValue

    Next i

.Cell(i + 1, 4).Range.Text = "总计：" 结束于在这种情况下，表格的第 1 行是标题；第 2 行是空的，并且没有其他行 - 因此 rows.add 应用一次以上附加了一行。表格可以是非常详细的文档，通过隐藏边框和单元格边框可以看起来像普通文本。表格按照文档流顺序编号。（即 Doc.Tables(1) 是第一个表...

【讨论】：