从一系列文档模板生成Word文档（在Excel VBA中） [英] Generate Word Documents (in Excel VBA) from a series of Document Templates

问题描述

嗯所有的。我会尽量让这个简单和简单。 ：）

我有

1. 40或所以需要填写一系列字段（名称，地址等）的样板文本文档，这是历史上手动完成的，但它是重复和繁琐的。


2. 一个工作簿，其中用户填写了一大笔关于个人的信息。

我需要

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

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

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

例如，对于set_of_templates
中的每个文档，如果document.FieldExists（Name）然后是文档，那么它的作用如下：

  field（Name）value = strName 
如果document.FieldExists（Address）then document.Field（Name）。value = strAddress 
 ... 
 
 document.saveAs（thisWorkbook.Path& \GeneratedDocs\& document.Name）
下一个文件
  

我考虑过的事情：

• 邮件合并 - 但这不足够，因为它需要手动打开每个文档并将工作簿构造为数据源，我想要的是相反的。模板是数据源，工作簿正在遍历它们。此外，邮件合并是使用不同数据的表创建许多相同的文档。我有很多文件都使用相同的数据。


• 使用诸如＃NAME＃之类的占位符文本，并打开每个文档进行搜索和替换。这是我提出的解决方案，如果没有提出更多的优雅。

解决方案

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

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

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

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

---

首先，我有一个包装方法，它负责维护一个微软单词的实例，迭代所有选择生成的文档，编号文档，并且做用户界面的东西（如处理错误，向用户显示文件夹等）。

 '目的：迭代并生成表单列表中的所有文档以生成
'通过创建用于所有生成的文档的持久性Word应用程序来提高速度
公共子生成策略（）
 Dim oWrd As New Word.Application 
 Dim srcPath As String 
 Dim cel As Range 
 
如果ERROR_HANDLING然后出现错误GoTo errmsg 
如果Forms.Cells（2，FormsT oGenerateCol）= vbNullString Then _ 
 Err.Raise 1，没有选择用于生成文档的表单。 
'获取将找到表单的文档库的路径。 
 srcPath = FindConstant（Document Repository）
'通过调用静态计数器函数，生成的每个表单将被顺序编号。这将重置它。 
 GetNextEndorsementNumber reset：= True 
'迭代每个窗体，调用函数来替换关键字并将副本保存到输出文件夹
对于每个cel在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 
'显示包含生成文档的文件夹
调用Shell（explorer.exe& CreateDocGenPath，vbNormalFocus）
 oWrd。退出False 
 Application.StatusBar = False 
如果MsgBox（策略生成完成，现在将记录保留信息，vbOKCancel，_ 
生成策略。 ）= vbOK然后Push_Reserving_Requirements 
退出子
 errmsg：
 MsgBox Err.Description，生成策略文档时出错
 End Sub 
  

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

 '目的：打开一个文档，并用特定关键字的各自的值代替所有实例。 
'如果现有的不作为参数传递，则创建Word的实例。 
'一旦填写了模板，将文档保存到目标路径。
'
'替换是使用两个帮助函数完成的，一个用于简单的关键字替换，
'一个用于更复杂的替换，如条件语句和时间表。 
 Private Sub RunReplacements（ByVal DocumentPath As String，ByVal SaveAsPath As String，_ 
可选ByRef oWrd As Word.Application = Nothing）
 Dim oDoc As Word.Document 
 Dim oWrdGiven As Boolean 
如果oWrd是Nothing然后设置oWrd =新的Word.Application Else oWrdGiven = True 
 
如果ERROR_HANDLING然后在错误GoTo docGenError 
 oWrd.Visible = False 
 oWrd .DisplayAlerts = wdAlertsNone 
 
 Application.StatusBar =Opening& Mid（DocumentPath，InStrRev（DocumentPath，\）+ 1）
设置oDoc = oWrd.Documents.Open（文件名：= DocumentPath，Visible：= False）
 RunAdvancedReplacements oDoc 
 RunSimpleReplacements oDoc 
 UpdateLinks oDoc'将更新Word中计算语句的例程（如当前日期）
 Application.StatusBar =Saving& Mid（DocumentPath，InStrRev（DocumentPath，\）+ 1）
 oDoc.SaveAs SaveAsPath 
 
 GoTo终于
 docGenError：
 MsgBox发生未知错误同时生成文件：& DocumentPath& vbNewLine _ 
& vbNewLine& Err.Description，vbCritical，Document Generation
最后：
如果不是oDoc不是，那么oDoc.Close False：设置oDoc = Nothing 
如果不是oWrdGiven Then oWrd.Quit False 
 End Sub 
  

然后调用 RunSimpleReplacements 。和 RunAdvancedReplacements 。在前者中，如果文档包含我们的关键字，则我们迭代文档生成关键字集合，并调用 WordDocReplace 。请注意，尝试更快，查找一堆单词，以确定它们不存在，然后不加区分地调用替换，所以我们总是检查一个关键字是否存在在尝试替换它之前。

 '目的：虽然很短，在列表表上使用生成关键字
'范围的帮助。它循环遍历文档
'中可能出现的每个简单关键字，并调用一个函数将其替换为定价中的相应数据。 
 Private Sub RunSimpleReplacements（ByRef oDoc As Word.Document）
 Dim DocGenKeys As Range，valueSrc As Range 
 Dim value As String 
 Dim i As Integer 
 
设置DocGenKeys = Lists.Range（DocumentGenerationKeywords）
对于i = 1到DocGenKeys.Rows.Count 
如果WordDocContains（oDoc，＃& DocGenKeys.Cells（i，1）.Text &＃）然后
'找到我们将用
替换占位符关键字的文本设置valueSrc = Range（Mid（DocGenKeys.Cells（i，2）.Formula，2））
如果valueSrc.MergeCells然后value = valueSrc.MergeArea.Cells（1，1）.Text Else value = valueSrc.Text 
'执行替换
 WordDocReplace oDoc，＃& DocGenKeys.Cells（i，1）.Text& ＃，value 
 End If 
 Next i 
 End Sub 
  

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

 '目的：调用每个替换的函数首先确定
'文档是否包含关键字，因此是否必须执行替换操作。 
公共功能WordDocContains（ByRef oDoc As Word.Document，ByVal searchFor As String）As Boolean 
 Application.StatusBar =检查关键字：& searchFor 
 WordDocContains = False 
 Dim storyRange As Word.Range 
对于每个storyRange在oDoc.StoryRanges 
 With storyRange.Find 
 .Text = searchFor 
 WordDocContains = WordDocContains或.Execute 
结束
如果WordDocContains然后退出
下一个
结束函数
  

这是橡胶满足道路的地方 - 执行替换的代码。这个例程比较复杂，因为遇到困难。以下是您只能从经验中学到的经验教训：

1. 您可以直接设置替换文本，也可以使用剪贴板。我发现如果您使用长度超过255个字符的字符串进行VBA替换，那么如果您尝试将其放在 Find.Replacement.Text ，但您可以使用^ c作为替换文本，它将直接从剪贴板中获取。这是我要使用的解决方法。




2. 只需调用replace就会在某些文本区域（如页眉和页脚）中遗漏关键字。因此，您实际上需要遍历 document.StoryRanges 并运行每个搜索和替换，以确保您捕获要替换的单词的所有实例




3. 如果要直接设置 Replacement.Text ，则需要转换Excel换行符（ vbNewLine 和 Chr（10））与一个简单的 vbCr




这解释了一切。意见也应该很清楚。这是执行魔法的金色例程：

 '目的：该功能实际上使用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 =替换关键字的实例：& replaceMe 
 
'我们要使用常规的搜索和替换，如果可以的话。它更快，并保留
'被替换的关键字的格式（如粗体）。如果字符串长度超过255个字符，则
'标准替换方法不起作用，因此我们必须使用不保留格式的剪贴板方法（^ c特殊字符）
'。这对于时间表是好的，它们始终是纯文本。 
如果Len（replaceWith）> 255 Then tooLong = True 
如果tooLong然后
 clipBoard.SetText IIf（replaceWith = vbNullString，，replaceWith）
 clipBoard.PutInClipboard 
 Else 
'转换excel -cell行打破字符换行符。 （如果使用剪贴板，则不需要）
 replaceWith = Replace（replaceWith，vbNewLine，vbCr）
 replaceWith = Replace（replaceWith，Chr（10），vbCr）
 End If 
'必须在多个StoryRanges上完成。不幸的是，只需调用replace就会在某些文本区域（如页眉和页脚）中错过
'个关键字。 
对于每个storyRange在oDoc.StoryRanges 
做
与storyRange.Find 
 .MatchWildcards = True 
 .Text = replaceMe 
 .Replacement.Text = IIf （太长，^ c，replaceWith）
 .Wrap = wdFindContinue 
 .Execute替换：= wdReplaceAll 
结束
错误恢复下一步
设置storyRange = storyRange .NextStoryRange 
错误GoTo 0 
循环而不是storyRange是没有
下一个
如果tooLong然后clipBoard.SetText
如果太长然后clipBoard.PutInClipboard 
 End Sub 
  

当灰尘沉降时，我们留下了一个漂亮版本的初始文档，生产值代替那些哈希标记的关键字。我很想举一个例子，但当然每个填写的文件都包含所有的专有信息。

---

唯一的想想提到我想是 RunAdvancedReplacements 部分。它做的东西非常相似 - 最终调用相同的 WordDocReplace 函数，但是这里使用的关键字特别是它们不链接到原来的单个单元格工作簿，它们在工作簿中的列表中生成代码隐藏。因此，例如，其中一个高级替换将如下所示：

 '生成日程表容器
如果WordDocContains（oDoc，＃VESSELSCHEDULE＃）然后_ 
 WordDocReplace oDoc，＃VESSELSCHEDULE＃，GenerateVesselSchedule（）
  

然后，将有一个对应的例程，它将包含用户配置的所有容器信息的字符串组合在一起：

< pre class =lang-vb prettyprint-override> '目的：根据用户的配置
'在预订标签中生成船只表中的船只列表。用户可以选择生成一个或两个拥有的船舶
'和特许船只，以及要显示的栏位。使用辅助功能
公共函数GenerateVesselSchedule（）As String
Dim值As String

Application.StatusBar =生成船只表。
如果Booking.Range（ListVessels）。value =是然后
Dim VesselCount As Long

如果Booking.Range（ListVessels）。Offset（1） .value =是然后_
value = value& GenerateVesselScheduleHelper（Vessels，VesselCount）
如果Booking.Range（ListVessels）。Offset（1）.value =Yes和_
Booking.Range（ListVessels）。 ）.value =是然后_
value = value& （特许船只）& vbNewLine
如果Booking.Range（ListVessels）。偏移量（2）.value =是然后_
value = value& GenerateVesselScheduleHelper（CharteredVessels，VesselCount）
如果Len（value）> 2然后value = Left（value，Len（value） - 2）'删除尾随行break
Else
GenerateVesselSchedule = Booking.Range（VesselSchedAlternateText）。文本
End If
GenerateVesselSchedule = value
End Function

'目的：船只计划生成程序的辅助功能。根据通过的进度参数生成拥有或
'特许船只。列表编号，并包含
'用户在预订表上选择的信息。
'SENSITIVE：请注意，此例程对配额报价选项卡上的船只计划选项卡和
'参数的布局敏感。如果任何一个变化，都应该重新审视。
公共函数GenerateVesselScheduleHelper（ByVal schedule As String，ByRef VesselCount As Long）As String
Dim值As String，nextline As String
Dim numInfo As Long，iRow As Long，iCol As Long
Dim Inclusions（）As Boolean，Columns（）As Long

'收集关于在日程表中显示的船只信息的信息
With Booking.Range（VesselInfoToInclude）
numInfo = Booking.Range（.Cells（1，1），.End（xlToRight））。Columns.Count - 1
ReDim包含（1到numInfo）
ReDim列（1到numInfo）
On Error Resume Next'某些列不会被识别
对于iCol = 1至numInfo
包含（iCol）= .Offset（0，iCol）=是
列（ iCol）= sumSchedVessels.Range（schedule）.Cells（1）.EntireRow.Find（.Offset（-1，iCol））。列
下一步iCol
错误GoTo 0
结束于

'构建调度
使用sumSchedVessels.Range（计划）
对于iRow = .row + 1 To .row + .Rows.Count - 1
如果Len（sumSchedVessels.Cells（iRow，Columns（1））。value）> 0然后
VesselCount = VesselCount + 1
value = value&船舶运输 &安培; vbTab
nextline = vbNullString
'添加描述字符串中包含的每个属性
如果包含（1）Then nextline = nextline& sumSchedVessels.Cells（iRow，Columns（1））& vbTab
如果包含（2）Then nextline = nextline& 建：& sumSchedVessels.Cells（iRow，Columns（2））& vbTab
如果包含（3）Then nextline = nextline& 长度：& _
格式（sumSchedVessels.Cells（iRow，Columns（3）），＃）& vbTab
如果包含（4）Then nextline = nextline& & sumSchedVessels.Cells（iRow，Columns（4））& vbTab
如果包含（5）Then nextline = nextline& 船体值：& _
格式（sumSchedVessels.Cells（iRow，Columns（5）），$＃，## 0）& vbTab
如果包含（6）Then nextline = nextline& 四：& _
格式（sumSchedVessels.Cells（iRow，Columns（6）），$＃，## 0）& vbTab
如果包含（7）Then nextline = nextline& TIV：& _
格式（sumSchedVessels.Cells（iRow，Columns（7）），$＃，## 0）& vbTab
如果包含（8）和schedule =CharteredVessels然后_
nextline = nextline& 免赔：&格式（bmCharterers.Range（schedule）.Cells（_
iRow - .row，9），$＃，## 0）& vbTab
nextline = Left（nextline，Len（nextline） - 1）'删除拖尾标签
'如果包含4个以上的属性包含在第4个之后插入一个新行
Dim tabloc As Long：tabloc = 0
Dim counter As Long：counter = 0
Do
tabloc = tabloc + 1
tabloc = InStr（tabloc，nextline，vbTab）
如果tabloc> 0然后counter = counter + 1
循环while tabloc> 0和计数器4
如果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个字符，它将适当地使用剪贴板方法。

所以这个模板：

加此电子表格数据 p>

成为本文档：

---

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

Hey all. I'll try to make this brief and simple. :)

I have

1. 40 or so boilerplate word documents with a series of fields (Name, address, etc) that need to be filled in. This is historically done manually, but it's repetitive and cumbersome.
2. A workbook where a user has filled a huge set of information about an individual.

I need

• A way to programatically (from Excel VBA) open up these boilerplate documents, edit in the value of fields from various named ranges in the workbook, and save the filled in templates to a local folder.

If I were using VBA to programatically edit particular values in a set of spreadsheets, I would edit all those spreadsheets to contain a set of named ranges which could be used during the auto-fill process, but I'm not aware of any 'named field' feature in a Word document.

How could I edit the documents, and create a VBA routine, so that I can open each document, look for a set of fields which might need to be filled in, and substitute a value?

For instance, something that works like:

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

Things I've considered:

• Mail merge - but this is insufficient because it requires opening each document manually and structuring the workbook as a data source, I kind of want the opposite. The templates are the data source and the workbook is iterating through them. Also, mail merge is for creating many identical documents using a table of different data. I have many documents all using the same data.
• Using placeholder text such as "#NAME#" and opening each document for a search and replace. This is the solution I would resort to if nothing more elegant is proposed.

解决方案

It's been a long time since I asked this question, and my solution has undergone more and more refinement. I've had to deal with all sorts of special cases, such as values that come directly from the workbook, sections that need to be specially generated based on lists, and the need to do replacements in headers and footers.

As it turns out, it did not suffice to use bookmarks, as it was possible for users to later edit documents to change, add, and remove placeholder values from the documents. The solution was in fact to use keywords such as this:

This is just a page from a sample document which uses some of the possible values that can get automatically inserted into a document. Over 50 documents exist with completely different structures and layouts, and using different parameters. The only common knowledge shared by the word documents and the excel spreadsheet is a knowledge of what these placeholder values are meant to represent. In excel, this is stored in a list of document generation keywords, which contain the keyword, followed by a reference to the range that actually contains this value:

These were the key two ingredients required. Now with some clever code, all I had to do was iterate over each document to be generated, and then iterate over the range of all known keywords, and do a search and replace for each keyword in each document.

---

First, I have the wrapper method, which takes care of maintaining an instance of microsoft word iterating over all documents selected for generation, numbering the documents, and doing the user interface stuff (like handling errors, displaying the folder to the user, etc.)

' 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

That routine calls RunReplacements which takes care of opening the document, prepping the environment for a fast replacement, updating links once done, handling errors, etc:

' 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

That routine then invokes RunSimpleReplacements. and RunAdvancedReplacements. In the former, we iterate over the set of Document Generation Keywords and call WordDocReplace if the document contains our keyword. Note that it's much faster to try and Find a bunch of words to figure out that they don't exist, then to call replace indiscriminately, so we always check if a keyword exists before attempting to replace it.

' 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

This is the function used to detect whether a keyword exists in the document:

' 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

And this is where the rubber meets the road - the code that executes the replacement. This routine got more complicated as I encountered difficulties. Here are the lessons you will only learn from experience:

1. You can set the replacement text directly, or you can use the clipboard. I found out the hard way that if you are doing a VBA replace in word using a string longer than 255 characters, the text will get truncated if you try to place it in the Find.Replacement.Text, but you can use "^c" as your replacement text, and it will get it directly from the clipboard. This was the workaround I got to use.

2. Simply calling replace will miss keywords in some text areas like headers and footers. Because of this, you actually need to iterate over the document.StoryRanges and run the search and replace on each one to ensure that you catch all instances of the word you want to replace.

3. If you're setting the Replacement.Text directly, you need to convert Excel line breaks (vbNewLine and Chr(10)) with a simple vbCr for them to appear properly in word. Otherwise, anywhere your replacement text has line breaks coming from an excel cell will end up inserting strange symbols into word. If you use the clipboard method however, you do not need to do this, as the line breaks get converted automatically when put in the clipboard.

That explains everything. Comments should be pretty clear too. Here's the golden routine that executes the magic:

' 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

When the dust settles, we're left with a beautiful version of the initial document with production values in place of those hash marked keywords. I'd love to show an example, but of course every filled in document contain all-proprietary information.

---

The only think left to mention I guess would be that RunAdvancedReplacements section. It does something extremely similar - it ends up calling the same WordDocReplace function, but what's special about the keywords used here is that they don't link to a single cell in the original workbook, they get generated in the code-behind from lists in the workbook. So for instance, one of the advanced replacements would look like this:

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

And then there will be a corresponding routine which puts together a string containing all the vessel information as configured by the user:

' 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

the resulting string can be used just like the contents of any excel cell, and passed to the replacement function, which will appropriately use the clipboard method if it exceeds 255 characters.

So this template:

Plus this spreadsheet data:

Becomes this document:

---

I sincerely hope that this helps someone out some day. It was definitely a huge undertaking and a complex wheel to have to re-invent. The application is huge, with over 50,000 lines of VBA code, so if I've referenced a crucial method in my code somewhere that someone needs, please leave a comment and I'll add it in here.

这篇关于从一系列文档模板生成Word文档（在Excel VBA中）的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！