Find/Replace Text from Headers in a Word Document Using VBA in Excel

Question

I am relatively new to VBA coding in Excel. I have adapted this VBA code for my use in order to replace all tagged text with what is in the Excel sheet. This works as intended for the main content in the word document. The only issue I have is that it is not searching/replacing text in the headers of the Word document. Does anyone have any suggestions as to editing the code to find and replace the text in the headers? I am sure it is something simple like defining the right object, but I cannot figure it out. Thank you!

 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 and I both recommended looking at the MVP web page by Jonathan West, Peter Hewitt, Doug Robbins and Greg Maxey. Here is a partial quotation.

This is Word code so you will need tag it to your WordDoc object instead of ActiveDocument.

The complete code to find or replace text anywhere is a bit complex. Accordingly, let's take it a step at a time to better illustrate the process. In many cases the simpler code is sufficient for getting the job done.

Step 1

The following code loops through each StoryRange in the active document and replaces the specified.Text with.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

(Note for those already familiar with VBA: whereas if you use Selection.Find, you have to specify all of the Find and Replace parameters, such as.Forward = True, because the settings are otherwise taken from the Find and Replace dialog's current settings, which are “sticky”, this is not necessary if using [Range].Find – where the parameters use their default values if you don't specify their values in your code).

The simple macro above has shortcomings. It only acts on the "first" StoryRange of each of the eleven StoryTypes (ie, the first header, the first textbox, and so on). While a document only has one wdMainTextStory StoryRange, it can have multiple StoryRanges in some of the other StoryTypes. If, for example, the document contains sections with un-linked headers and footers, or if it contains multiple textboxes, there will be multiple StoryRanges for those StoryTypes and the code will not act upon the second and subsequent StoryRanges. To even further complicate matters, if your document contains unlinked headers or footers and one of the headers or footers are empty then VBA can have trouble "jumping" that empty header or footer and process subsequent headers and footers.

Step 2

To make sure that the code acts on every StoryRange in each each StoryType, you need to:

 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

There is one remaining problem. Just like with the Find and Replace utility, the code above can miss any text that is contained in one StoryType/StoryRange nested in a different StoryType/StoryRange. While this problem does not occur with a nested StoryType/StoryRange in the wdMainTextStory StoryRange, it does occur in header and footer type StoryRanges. An example is textbox that is located in a header or footer.

Step 3

Fortunately Jonathan West provided a work around for the problem of such nested StoryRanges. The work around makes use of the fact that Textboxes and other Drawing Shapes are contained in a document's ShapeRange collection. We can therefore check the ShapeRange in each of the six header and footer StoryRanges for the presence of Shapes. If a Shape is found, we then check each Shape for the presence of the text, and finally, if the Shape contains text we set our search range to that Shape's.TextFrame.TextRange.

This final macro contains all of the code to find and replace text “anywhere” in a document. A few enhancements have been added to make it easier to apply the desired find and replace text strings.

Note: It is important to convert the code text to plain text before you paste: if you paste directly from a web browser, spaces are encoded as non-breaking spaces, which are not "spaces" to VBA and will cause compile- or run-time errors. Also: Be careful of the long lines in this code. When you paste this code into the VBA Editor, there should be NO red visible anywhere in what you pasted. If there is, try carefully joining the top red line with the one below it (without deleting any visible characters.

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