在 Excel 中使用 VBA 从 Word 文档的标题中查找/替换文本

Question

我对 Excel 中的 VBA 编码比较陌生。我已经修改了这个 VBA 代码以供我使用，以便用 Excel 工作表中的内容替换所有标记的文本。这适用于 word 文档中的主要内容。我唯一的问题是它没有在 Word 文档的标题中搜索/替换文本。有没有人对编辑代码以查找和替换标题中的文本有任何建议？我确信这很简单，比如定义正确的对象，但我无法弄清楚。谢谢！

 Dim CustRow, CustCol, TemplRow As Long
 Dim DocLoc, TagName, TagValue, TemplName, FileName As String
 Dim CurDt, LastAppDt As Date
 Dim WordDoc, WordApp As Object
 Dim WordContent, WordHeaderFooter As Word.Range
 With Sheet106

    TemplRow = .Range("B3").Value 'Set Template Row
    TemplName = .Range("J3").Value 'Set Template Name
    DocLoc = .Range("E" & TemplRow).Value 'Word Document Filename
    
    'Open Word Template
    On Error Resume Next 'If Word is already running
    Set WordApp = GetObject("Word.Application")
    If Err.Number <> 0 Then
    'Launch a new instance of Word
    Err.Clear
    'On Error GoTo Error_Handler
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True 'Make the application visible to the user
  End If

  CustRow = 4
  Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
  For CustCol = 16 To 180 'Move Through all Columns
       TagName = .Cells(3, CustCol).Value 'Tag Name
       TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
       With WordDoc.Content.Find
           .Text = TagName
           .Replacement.Text = TagValue
           .Wrap = wdFindContinue
           .Execute Replace:=wdReplaceAll 'Find & Replace all instances
       End With
   Next CustCol

                                                        
   If .Range("J1").Value = "PDF" Then
       FileName = ThisWorkbook.Path & "\" & .Range("Q" & CustRow).Value & _
              "_" & .Range("P" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
       WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
       WordDoc.Close False
   Else: 'If Word
       FileName = ThisWorkbook.Path & "\" & .Range("Q" & CustRow).Value _
              & "_" & .Range("P" & CustRow).Value & ".docx"
       WordDoc.SaveAs FileName
   End If
End With
End Sub

Answer 1

Tim Williams 和我都建议查看 Jonathan West、Peter Hewitt、Doug Robbins 和 Greg Maxey 的 MVP web page。这是部分引文。

这是 Word 代码，因此您需要将其标记到 WordDoc 对象而不是 ActiveDocument。

在任何地方查找或替换文本的完整代码有点复杂。 因此，让我们一步一步来更好地说明 过程。在许多情况下，更简单的代码就足以获得 工作完成。

步骤 1

以下代码循环遍历活动中的每个 StoryRange 文档并将指定的 .Text 替换为 .Replacement.Text：

Sub FindAndReplaceFirstStoryOfEachType()
  Dim rngStory As Range
  For Each rngStory In ActiveDocument.StoryRanges
    With rngStory.Find
      .Text = "find text"
      .Replacement.Text = "I'm found"
      .Wrap = wdFindContinue
      .Execute Replace:=wdReplaceAll
    End With
  Next rngStory
End Sub

（对于那些已经熟悉 VBA 的人请注意：而如果您使用 Selection.Find，你必须指定所有的Find and Replace 参数，比如.Forward = True，因为设置是 否则取自“查找和替换”对话框的当前设置， 它们是“粘性的”，如果使用 [Range]，则没有必要。查找 - 如果您不指定，参数将使用其默认值 它们在您的代码中的值）。

上面的简单宏有缺点。它只作用于“第一” 十一个 StoryType 中的每一个的 StoryRange（即第一个标题， 第一个文本框，依此类推）。虽然一个文档只有一个 wdMainTextStory StoryRange，它可以有多个 StoryRanges 其他 StoryTypes。例如，如果文档包含 具有未链接页眉和页脚的部分，或者如果它包含 多个文本框，这些文本框将有多个 StoryRanges StoryTypes 和代码不会作用于第二个和后续 故事范围。更复杂的是，如果您的文件 包含未链接的页眉或页脚以及页眉或页脚之一 为空，则 VBA 可能无法“跳转”该空标题或 页脚并处理后续页眉和页脚。

第二步

确保代码作用于每个 StoryRange 中的每个 StoryType，您需要：

Make use of the NextStoryRange method
Employ a bit of VBA "trickery" as provided by Peter Hewett to bridge any empty unlinked headers and footers.

Public Sub FindReplaceAlmostAnywhere()
  Dim rngStory As Word.Range
  Dim lngJunk As Long
  'Fix the skipped blank Header/Footer problem as provided by Peter Hewett
  lngJunk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
  'Iterate through all story types in the current document
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories
    Do
      With rngStory.Find
        .Text = "find text"
        .Replacement.Text = "I'm found"
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
      End With
      'Get next linked story (if any)
      Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next
End Sub

还有一个问题。就像查找和替换一样 实用程序，上面的代码可能会错过包含在一个 StoryType/StoryRange 嵌套在不同的 StoryType/StoryRange 中。尽管 嵌套 StoryType/StoryRange 不会出现此问题 wdMainTextStory StoryRange，它确实出现在页眉和页脚类型中 故事范围。一个示例是位于标题中的文本框或 页脚。

第三步

幸运的是，乔纳森·韦斯特提供了解决问题的方法 这样嵌套的 StoryRanges。解决方法利用了以下事实 文本框和其他绘图形状包含在文档的 ShapeRange 集合。因此，我们可以检查每个中的 ShapeRange Shapes 存在的六个页眉和页脚 StoryRanges 中的一个。 如果找到一个 Shape，我们然后检查每个 Shape 是否存在 文本，最后，如果 Shape 包含文本，我们设置搜索范围 到那个 Shape 的 .TextFrame.TextRange。

这个最终的宏包含查找和替换文本的所有代码 文档中的“任何地方”。添加了一些增强功能以​​使 更容易应用所需的查找和替换文本字符串。

注意：将代码文本转换为纯文本之前很重要 你粘贴：如果你直接从网络浏览器粘贴，空格是 编码为不间断空格，这不是 VBA 的“空格”，并且将 导致编译或运行时错误。另外：小心长线 在这段代码中。当您将此代码粘贴到 VBA 编辑器中时， 在您粘贴的任何地方都应该没有红色可见。如果有， 尝试小心地将顶部的红线与下面的红线连接起来（没有 删除所有可见字符。

Public Sub FindReplaceAnywhere()
  Dim rngStory As Word.Range
  Dim pFindTxt As String
  Dim pReplaceTxt As String
  Dim lngJunk As Long
  Dim oShp As Shape
  pFindTxt = InputBox("Enter the text that you want to find." _
    , "FIND" )
  If pFindTxt = "" Then
    MsgBox "Cancelled by User"
    Exit Sub
  End If
  TryAgain:
  pReplaceTxt = InputBox( "Enter the replacement." , "REPLACE" )
  If pReplaceTxt = "" Then
    If MsgBox( "Do you just want to delete the found text?", _
     vbYesNoCancel) = vbNo Then
      GoTo TryAgain
    ElseIf vbCancel Then
      MsgBox "Cancelled by User."
      Exit Sub
    End If
  End If
  'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
  'Iterate through all story types in the current document
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories
    Do
      SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
      On Error Resume Next
      Select Case rngStory.StoryType
      Case 6 , 7 , 8 , 9 , 10 , 11
        If rngStory.ShapeRange.Count > 0 Then
          For Each oShp In rngStory.ShapeRange
            If oShp.TextFrame.HasText Then
              SearchAndReplaceInStory oShp.TextFrame.TextRange, _
                  pFindTxt, pReplaceTxt
            End If
          Next
        End If
      Case Else
        'Do Nothing
      End Select
      On Error GoTo 0
      'Get next linked story (if any)
      Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next
End Sub


Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
    ByVal strSearch As String , ByVal strReplace As String )
  With rngStory.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = strSearch
    .Replacement.Text = strReplace
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
End Sub