从一系列文档模板生成 Word 文档(在 Excel VBA 中) [英] Generate Word Documents (in Excel VBA) from a series of Document Templates
问题描述
大家好.我会尽量使这个简短而简单.:)
Hey all. I'll try to make this brief and simple. :)
我有
- 40 个左右的样板 Word 文档，其中包含需要填写的一系列字段(姓名、地址等).这在历史上是手动完成的，但重复且繁琐.
- 用户在其中填写了大量关于个人的信息的工作簿.
我需要
- 一种以编程方式(来自 Excel VBA)打开这些样板文档、编辑工作簿中各种命名范围的字段值并将填充的模板保存到本地文件夹的方法.
如果我使用 VBA 以编程方式编辑一组电子表格中的特定值，我会编辑所有这些电子表格以包含一组可在自动填充过程中使用的命名范围，但我不知道Word 文档中的任何命名字段"功能.
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.
如何编辑文档并创建 VBA 例程，以便我可以打开每个文档，查找可能需要填写的一组字段并替换值?
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 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#")并打开每个文档进行搜索和替换.如果没有更优雅的提议，这就是我会采用的解决方案.
推荐答案
好久没问这个问题了，我的解决方案也越来越细化了.我不得不处理各种特殊情况，例如直接来自工作簿的值、需要根据列表专门生成的部分以及需要在页眉和页脚中进行替换.
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:
这只是示例文档中的一个页面，它使用了一些可以自动插入到文档中的可能值.存在 50 多个文件，它们具有完全不同的结构和布局，并使用不同的参数.word文档和excel电子表格共享的唯一共同知识是这些占位符值的含义的知识.在 excel 中，这是存储在文档生成关键字列表中，其中包含关键字，后跟对实际包含此值的范围的引用:
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.
首先，我有一个包装器方法，它负责维护一个 microsoft word 的实例，它迭代所有选择生成的文档，给文档编号，并做用户界面的事情(比如处理错误，向用户显示文件夹等)
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
该例程调用 RunReplacements，它负责打开文档、为快速替换准备环境、完成后更新链接、处理错误等:
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
该例程然后调用RunSimpleReplacements.和 RunAdvancedReplacements.在前者中，我们遍历文档生成关键字集，如果文档包含我们的关键字，则调用 WordDocReplace.请注意，尝试 Find 一堆单词以找出它们不存在的速度要快得多，然后不加选择地调用 replace ，因此我们总是在尝试替换之前检查关键字是否存在.
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:
可以直接设置替换文本，也可以使用剪贴板.我发现如果您使用长度超过 255 个字符的字符串在 word 中进行 VBA 替换，那么如果您尝试将其放置在
Find.Replacement.Text中，文本将被截断，这很困难，但是您可以使用"^c"作为替换文本，它会直接从剪贴板中获取.这是我必须使用的解决方法.
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.
简单地调用 replace 会丢失某些文本区域(如页眉和页脚)中的关键字.因此，您实际上需要遍历 document.StoryRanges 并对每一个运行搜索和替换，以确保您捕获要替换的单词的所有实例.
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.
如果直接设置Replacement.Text，则需要转换Excel换行符(vbNewLine和Chr(10)code>) 和一个简单的 vbCr 以便它们在 word 中正确显示.否则，任何地方的替换文本都有来自 Excel 单元格的换行符，最终会在 word 中插入奇怪的符号.但是，如果您使用剪贴板方法，则无需执行此操作，因为将换行符放入剪贴板时会自动转换.
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.
我想剩下的唯一要提的就是 RunAdvancedReplacements 部分.它做了一些非常相似的事情——它最终调用了相同的 WordDocReplace 函数，但是这里使用的关键字的特别之处在于它们没有链接到原始工作簿中的单个单元格，而是在工作簿中列表的代码隐藏.因此，例如，其中一种高级替换看起来像这样:
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
结果字符串可以像任何excel单元格的内容一样使用，并传递给替换函数，如果超过255个字符，它将适当地使用剪贴板方法.
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.
所以这个模板:
加上这个电子表格数据:
成为这个文件:
我真诚地希望有一天这能帮助某人.这绝对是一项艰巨的任务，需要重新发明一个复杂的轮子.该应用程序非常庞大，有超过 50,000 行 VBA 代码，所以如果我在代码中引用了某人需要的关键方法，请发表评论，我会在此处添加.
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屋！
