使用Excel VBA从一系列文档模板生成Word文档

Question

大家好。我会尽量让这个问题简洁明了。:)

我的情况是

1. 大约有40份样板Word文档，其中有一系列需要填写的字段（姓名、地址等）。这些文档过去都是手动完成的，但是这种工作很重复且繁琐。
2. 一个用户已经填写了关于某个人的大量信息的工作簿。

我的需求是

• 一种编程方式（来自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

我考虑过以下几种方案：

• 邮件合并 - 但这不够好，因为它需要手动打开每个文档并将工作簿构造为数据源，我想要的正好相反。模板应该是数据源，而工作簿则通过迭代来使用它们。此外，邮件合并是用于使用不同数据表创建许多相同文档的情况。我有许多文档都使用相同的数据。
• 使用占位符文本，例如“#名称#”，并为每个文档打开搜索和替换。如果没有更好的解决方案，这是我会采用的解决方法。

- Alain

---

邮件合并不适合的原因是什么？ - Fionnuala

Mailmerge 可以从 VBA 运行，也就是说，数据源可以从 VBA 设置，并且您可以拥有任意数量的记录。我认为这比遍历不确定数量的字段要容易得多，需要的代码也更少。 - Fionnuala

我认为你可能从错误的角度看待邮件合并。它正是你想要的，即Excel保存要填入Word字段的数据。 - Fionnuala

邮件合并需要在所选的Excel文档中存在一个表格，该表格被配置为包含填充模板Word文档所需的数据。我没有这样的表格，也不想为需要填写的每个Word文档创建一个表格。我需要一个通用解决方案来替换一组预配置文档中的某些参数。工作簿不知道Word文档的结构，反之亦然。 - Alain

一种做法是使用 Word 文档中的书签和代码以及 Excel 中的命名区域和代码。要做得正确，获取 Professional Excel Development 的副本，其中有一个非常好的示例，我曾多次使用过。我刚刚尝试在网上搜索，只找到了片段，如果你打算继续进行这种工作，PED 是一本很棒的书籍。 - Doug Glancy

Answer 1

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

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

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

这是所需的两个关键因素。现在，通过一些巧妙的代码，我只需要迭代要生成的每个文档，然后迭代所有已知关键字的范围，并在每个文档中为每个关键字进行搜索和替换。

---

首先，我有一个包装器方法，它负责维护 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 如果文档包含我们的关键字。请注意，尝试查找一堆单词以确定它们不存在比不加选择地调用替换要快得多，因此我们始终在尝试替换之前检查关键字是否存在。

' 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

这就是关键所在——执行替换的代码。随着困难的出现，这个过程变得越来越复杂。下面是你只能通过经验学到的教训：

1. 您可以直接设置替换文本，或者使用剪贴板。我发现如果您在Word中使用长于255个字符的字符串进行VBA替换，则如果您尝试将其放置在Find.Replacement.Text中，文本将被截断，但您可以使用"^c"作为替换文本，它将直接从剪贴板获取。这是我使用的解决方法。

2. 仅调用替换将错过某些文本区域（如页眉和页脚）中的关键字。因此，您实际上需要遍历document.StoryRanges并对每个范围运行搜索和替换，以确保捕获要替换的所有单词实例。

3. 如果您直接设置Replacement.Text，则需要使用简单的vbCr将Excel换行符（vbNewLine和Chr(10)）转换为它们在Word中正确显示。否则，您的替换文本中任何来自Excel单元格的换行都会在Word中插入奇怪的符号。然而，如果您使用剪贴板方法，则不需要执行此操作，因为当放入剪贴板时，换行符会自动转换。

这解释了一切。评论应该也很清晰。以下是执行魔法的黄金例程：

' 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代码，因此如果我在我的代码中引用了某个关键方法，有人需要，请留下评论，我会在这里添加它。

- Alain

---

太棒了！我无法描述我有多开心，你以如此详细的方式发布了这个答案。 - indiv

非常好的回答，不过在我工作的地方，我们使用VB.NET构建了一个应用程序，每天可以处理数百封信件，并从SQL Server中提取数据... - Our Man in Bananas

在我们的.NET版本中，我们使用{}作为占位符来定位将被替换的字段。 - Our Man in Bananas

Answer 2

http://www.computorcompanion.com/LPMArticle.asp?ID=224介绍了Word中书签的使用方法。

文档中的一段文字可以被书签化，并赋予一个变量名。使用VBA，可以访问此变量，并将文档中的内容替换为备选内容。这是解决文档中占位符（如姓名和地址）的方案。

此外，使用书签，可以修改文档以引用书签化的文本。如果在文档中多次出现某个名称，则可以将第一个实例进行书签化，其他实例可以引用该书签。现在，当程序atically更改第一个实例时，文档中所有其他实例的变量也会自动更改。

现在只需要通过对占位符文本进行书签化并在整个文档中使用一致的命名约定来更新所有文档，然后迭代每个文档以替换书签（如果存在）：

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

我可以尝试在每次替换之前使用“On Error Resume Next”语句来解决在给定文档中未出现的变量的问题。

感谢Doug Glancy在评论中提到书签的存在。我之前不知道它们的存在。我会继续关注这个主题，看看这个解决方案是否足够。

- Alain

Answer 3

您可以考虑使用基于XML的方法。Word有一个名为Custom XML data-binding，或数据绑定内容控件的功能。内容控件本质上是文档中可包含内容的点。 "数据绑定"内容控件从您在docx zip文件中包含的XML文档获取其内容。 XPath表达式用于指定XML的哪个部分。因此，您只需要包含您的XML文件，Word将完成其余工作。Excel有将其作为XML输出数据的方法，因此整个解决方案应该很好地工作。MSDN上有大量关于内容控制数据绑定的信息（其中一些已在早期的SO问题中引用），因此我不会在此处包括它们。但您确实需要一种设置绑定的方法。您可以使用Content Control Toolkit，或者如果您想要在Word内部执行它，则可以使用我的OpenDoPE插件。

- JasonPlutext

---

这将是一个非常棒的方法，因为它不需要打开Word文件或使用Office互操作来更改内容。我会朝着那个方向进行一些研究。 - Alain

Answer 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 = "总计：" End With 在这种情况下，表格的第一行是标题；第二行为空，没有更多的行 - 因此当附加了一个以上的行时，Rows.Add应用了一次。表格可以是非常详细的文档，并且通过隐藏边框和单元格边框可以使其看起来像普通文本。表格按照文档流顺序依次编号。（即Doc.Tables(1)是第一个表格...）

- Simon N