使用 Excel 中的 VBA 從 Word 文檔的標題中查找/替換文本

Question

我對 Excel 中的 VBA 編碼比較陌生。 我已經修改了這個 VBA 代碼供我使用，以便用 Excel 表中的內容替換所有標記的文本。 這適用於 word 文檔中的主要內容。 我唯一的問題是它沒有在 Word 文檔的標題中搜索/替換文本。 是否有人對編輯代碼以查找和替換標題中的文本有任何建議？ 我確信這很簡單，比如定義正確的 object，但我無法弄清楚。 謝謝！

 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 頁面。 以下是部分引文。

這是 Word 代碼，因此您需要將其標記到 WordDoc object 而不是 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 則沒有必要 - 如果您未在代碼中指定參數值，則參數使用其默認值）。

上面的簡單宏有缺點。 它只作用於十一個 StoryType 中的每一個的“第一個”StoryRange（即第一個 header、第一個文本框等）。 雖然一個文檔只有一個 wdMainTextStory StoryRange，但它可以在其他一些 StoryTypes 中有多個 StoryRanges。 例如，如果文檔包含帶有未鏈接的頁眉和頁腳的部分，或者如果它包含多個文本框，則這些 StoryType 將有多個 StoryRanges，並且代碼不會對第二個和后續 StoryRanges 起作用。 更復雜的是，如果您的文檔包含未鏈接的頁眉或頁腳，並且頁眉或頁腳之一為空，則 VBA 可能無法“跳轉”空 header 或頁腳並處理后續頁眉和頁腳。

第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 不會出現此問題，但它確實會出現在 header 和頁腳類型 StoryRanges 中。 例如，位於 header 或頁腳中的文本框。

第 3 步

幸運的是，Jonathan West 為這種嵌套的 StoryRanges 問題提供了一種解決方法。 解決方法利用了文本框和其他繪圖形狀包含在文檔的 ShapeRange 集合中這一事實。 因此，我們可以檢查六個 header 和頁腳 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