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

4 回答

• 3

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

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

  

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

  

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

  ---

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

  ' 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 一堆字来判断它们不存在然后不加选择地调用replace会快得多，所以我们总是在尝试替换之前检查关键字是否存在 .

  ' 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
  

  这就是橡胶遇到道路的地方 - 执行更换的代码 . 当我遇到困难时，这个程序变得更加复杂 . 以下是您只能从经验中学到的课程：

  • 您可以直接设置替换文本，也可以使用剪贴板 . 我发现了一个很难的方法，如果你正在进行VBA取代使用长度超过255个字符的字符串，如果您尝试将文本放在_3030869中，文本将被截断，但您可以使用 "^c" 作为替换文本，它将直接从剪贴板获取 . 这是我使用的解决方法 .

  • 简单地调用replace会在页眉和页脚等文本区域中遗漏关键字 . 因此，您实际上需要遍历 document.StoryRanges 并运行搜索并替换每一个以确保捕获要替换的单词的所有实例 .

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

  这解释了一切 . 评论也应该很清楚 . 这是执行魔术的黄金例程：

  ' 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 函数，但是's special about the keywords used here is that they don't链接到原始工作簿中的单个单元格，它们是从工作簿中的列表中的代码隐藏生成的 . 因此，例如，其中一个高级替换将如下所示：

  '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个字符，它将适当地使用剪贴板方法 .

  So this template:

  

  Plus this spreadsheet data:

  

  Becomes this document:

  

  ---

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

  回复于 2024-05-04T03:59:18+08:00
• 2

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

  可以为文档中的一段文本添加书签，并为其指定变量名称 . 使用VBA，可以访问此变量，并且可以使用备用内容替换文档中的内容 . 这是在文档中使用名称和地址等占位符的解决方案 .

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

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

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

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

  感谢Doug Glancy在他的评论中提到了书签的存在 . 我事先并不知道他们的存在 . 我会在这个主题是否满足时发布这个主题 .

  回复于 2024-05-04T03:59:18+08:00
• 0

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

  Word具有称为自定义XML数据绑定或数据绑定内容控件的功能 . 内容控件本质上是文档中可以包含内容的一个点 . “数据绑定”内容控件从您包含在docx zip文件中的XML文档中获取其内容 . XPath表达式用于表示XML的哪个位 . 所以你需要做的就是包含你的XML文件，Word将完成剩下的工作 .

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

  有关MSDN上内容控制数据绑定的大量信息（其中一些已在早期的SO问题中引用）我不会在这里包括他们 .

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

  回复于 2024-05-04T03:59:18+08:00
• 29

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

  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 =“Total：”End在这种情况下，表格的第1行是 Headers ;第2行是空的，没有其他行 - 因此rows.add仅在连接一行时应用 . 表格可以是非常详细的文档，通过隐藏边框和单元格边框可以看起来像普通文本 . 表格按文件流程顺序编号 . （即Doc.Tables（1）是第一个表......

  回复于 2024-05-04T03:59:18+08:00