Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String
 
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
Application.ScreenUpdating = True
End Sub

Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Sub UpdateDocuments(oFolder As String)
Dim strFldr As String, strFile As String, wdDoc As Document
Dim Rng As Range, Sctn As Section, HdFt As HeaderFooter, Shp As Shape
strFldr = oFolder
If strFldr = "" Then Exit Sub
strFile = Dir(strFldr & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFldr & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=False)
  With wdDoc
    'Loop through all story ranges
    For Each Rng In .StoryRanges
      Call FndRepRng(Rng)
      For Each Shp In Rng.ShapeRange
        If Not Shp.TextFrame Is Nothing Then
          Call FndRepRng(Shp.TextFrame.TextRange)
        End If
      Next
    Next
    'Loop through all headers & footers
    For Each Sctn In .Sections
      For Each HdFt In Sctn.Headers
        With HdFt
          If .Exists = True Then
            If .LinkToPrevious = False Then
              Call FndRepRng(HdFt.Range)
              For Each Shp In .Shapes
                If Not Shp.TextFrame Is Nothing Then
                  Call FndRepRng(Shp.TextFrame.TextRange)
                End If
              Next
            End If
          End If
        End With
      Next
      For Each HdFt In Sctn.Footers
        With HdFt
          If .Exists = True Then
            If .LinkToPrevious = False Then
              Call FndRepRng(HdFt.Range)
              For Each Shp In .Shapes
                If Not Shp.TextFrame Is Nothing Then
                  Call FndRepRng(Shp.TextFrame.TextRange)
                End If
              Next
            End If
          End If
        End With
      Next
    Next
    'Save and close the document
    .Close SaveChanges:=wdSaveChanges
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
End Sub

Sub FndRepRng(Rng As Range)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "Find string"
  .Replacement.Text = "Replace string"
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .Execute Replace:=wdReplaceAll
End With
End Sub