If these document are past correspondence, there could be adverse legal implications resulting from changing the content this way, as the documents will no longer be an accurate reflection of the documents actually used; doing so will also invalidate all your backups. This is especially important in the corporate environment. That said, try:
Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String
Dim wdDocTgt As Document, wdDocSrc As Document
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder: StrFolds = vbCr & TopLevelFolder
If TopLevelFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
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
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Sub UpdateDocuments(oFolder As String)
Dim strFolder As String, strFile As String
strFolder = oFolder
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> wdDocSrc.FullName Then
Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
AddToRecentFiles:=False, Visible:=False)
With wdDocTgt
.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText = _
wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
.Close SaveChanges:=True
End With
End If
strFile = 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
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
RecurseWriteFolderName (SubFolder)
Next
End Sub