title: VBA Replace in Word from Excel including headers, footers and footnotes
body: <p>I have some data on an Excel file which I want to search-replace into a Word document through an Excel VBA macro. There are two columns: one with the things I want to look for, and another one for the replacement text. That works fine.</p>
  
  <p>The problem is that I want to replace also inside the HEADERS, FOOTERS, FOOTNOTES and ENDNOTES. I've tried some code with things from the Internet, but it does not fulfill its mission... Any help?</p>
  
  <pre><code>Sub ReplacetoWord()
  
  Dim rngStory As Word.Range
  Dim lngJunk As Long
  Dim oShp As Shape
  Dim name_book As String
  Dim x As Variant
  Dim Filename As String
  Dim wArch As String
  
  name_book = ThisWorkbook.FullName
  x = Split(name_book, Application.PathSeparator)
  Filename = x(UBound(x))
  
  Sheets("Generate_Report").Select
  wArch = Range("C3").Text &amp; Range("C2").Text &amp; ".docx"
  
  Set objWord = CreateObject("Word.Application")
  objWord.Documents.Open wArch
  objWord.Visible = True
  
  Workbooks(Filename).Activate
  Worksheets("Generate_Report").Select
  
  'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  
  For i = 1 To Range("I1").Value 'cell with the number of data to replace
  
  Workbooks(Filename).Activate
  Worksheets("Generate_Report").Select
  
  datos = Range("B" &amp; i).Text 'what to look for
  reemp = Range("A" &amp; i).Text 'what to replace with
  
    For Each rngStory In ActiveDocument.StoryRanges
      'Iterate through all linked stories
      Do
        With objWord.Selection.Find
         .Text = datos 
         .Replacement.Text = reemp 
         .Wrap = wdFindContinue
         .Execute Replace:=wdReplaceAll 
        End With
        On Error Resume Next
        Select Case rngStory.StoryType
        Case 6, 7, 8, 9, 10, 11
          If rngStory.ShapeRange.count &gt; 0 Then
            For Each oShp In rngStory.ShapeRange
              If oShp.TextFrame.HasText Then
                With objWord.Selection.Find
                  .Text = datos 
                  .Replacement.Text = reemp 
                  .Wrap = wdFindContinue
                  .Execute Replace:=wdReplaceAll 
                End With
              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
  
  
  Next i
  
  objWord.Activate
  
  
  End Sub
  </code></pre>