Option Explicit
Dim FSO As Object, oFolder As Object, StrFldrs As String
Dim DocSrc As Document, DocTgt As Document, RngHd As Range, RngFt As Range
Dim StrPth As String, StrNm As String, StrSrc As String
 
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder: If TopLevelFolder = "" Then Exit Sub
Set DocSrc = ActiveDocument: StrSrc = DocSrc.FullName
Set RngHd = DocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range
Set RngFt = DocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range
StrFldrs = 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(StrFldrs, vbCr))
  Call UpdateDocuments(CStr(Split(StrFldrs, vbCr)(i)))
Next
Set RngHd = Nothing: Set RngFt = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Set TheFolders = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

Sub UpdateDocuments(StrPth As String)
StrNm = Dir(StrPth & "\*.doc", vbNormal)
While StrNm <> ""
  If StrPth & "\" & StrNm <> StrSrc Then
    Set DocTgt = Documents.Open(FileName:=StrPth & "\" & StrNm, AddToRecentFiles:=False, Visible:=False)
    With DocTgt
      With .Sections.First.Headers(wdHeaderFooterPrimary).Range
        .FormattedText = RngHd.FormattedText
        .Characters.Last.Text = vbNullString
      End With
      With .Sections.First.Footers(wdHeaderFooterPrimary).Range
        .FormattedText = RngFt.FormattedText
        .Characters.Last.Text = vbNullString
      End With
      .Close True
    End With
  End If
  StrNm = Dir()
Wend
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 RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFldrs = StrFldrs & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub