时间戳

首页 > 解决方案 > 在 Excel 中使用 VBA 从 Word 文档的标题中查找/替换文本

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

问题描述

我对 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

标签： excelvbams-word

解决方案

Tim Williams 和我都建议查看 Jonathan West、Peter Hewitt、Doug Robbins 和 Greg Maxey 的MVP 网页。以下是部分引文。

这是 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，则必须指定所有查找和替换参数，例如 .Forward = True，否则这些设置取自“查找和替换”对话框的当前设置，这是“粘性的”，如果使用 [Range].Find 则没有必要 - 如果您未在代码中指定参数值，则参数使用其默认值）。

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

第2步

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

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 中包含的任何文本。虽然 wdMainTextStory StoryRange 中的嵌套 StoryType/StoryRange 不会出现此问题，但它确实会出现在页眉和页脚类型 StoryRanges 中。一个示例是位于页眉或页脚中的文本框。

第 3 步

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

这个最终的宏包含在文档中“任意位置”查找和替换文本的所有代码。添加了一些增强功能，以便更轻松地应用所需的查找和替换文本字符串。

注意：在粘贴之前将代码文本转换为纯文本很重要：如果直接从 Web 浏览器粘贴，空格被编码为不间断空格，这不是 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

推荐阅读