Try something along the lines of:
Code:
Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
Dim wdRngSrc As Range, wdRngTgt As Range
Dim Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
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
For Each Sctn In .Sections
'For Headers
For Each HdFt In Sctn.Headers
With HdFt
If .Exists Then
If Sctn.Index = 1 Then
Set wdRngTgt = .Range.Characters.First
wdRngTgt.End = wdRngTgt.End + 51
Set wdRngSrc = wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Characters.First
wdRngSrc.End = wdRngSrc.End + 51
wdRngTgt.FormattedText = wdRngSrc.FormattedText
ElseIf .LinkToPrevious = False Then
Set wdRngTgt = .Range.Characters.First
wdRngTgt.End = wdRngTgt.End + 51
Set wdRngSrc = wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Characters.First
wdRngSrc.End = wdRngSrc.End + 51
wdRngTgt.FormattedText = wdRngSrc.FormattedText
End If
End If
End With
Next
Next
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
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