Option Explicit
 
Private Sub cbOptionOK_Click()
 
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim strFnd As String, strRep As String, wdStory(), i As Long
Dim wdDocTgt As Document, wdDocSrc As Document
Dim Sctn As Section, HdFt As HeaderFooter
 
'Cue function to select folder where specification files are found
 
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
 
Unload Me
 
Select Case cboHFList.Value
 
Case "Replace header"
 
      With Application.Dialogs(wdDialogFileOpen) 'Open header source file
      If .Show = -1 Then
        Set wdDocSrc = ActiveDocument
      Else
        MsgBox "No Source document chosen. Exiting", vbExclamation
        Exit Sub
      End If
    End With
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
        Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
        AddToRecentFiles:=False, Visible:=False)
        With wdDocTgt
            For Each Sctn In .Sections
                For Each HdFt In Sctn.Headers
                    With HdFt
                        If .Exists Then
                            If .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.Copy
                                wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.PasteAndFormat wdFormatOriginalFormatting
                            End If
                        End If
                    End With
                Next
            Next
            .Close SaveChanges:=True
        End With
                strFile = Dir()
    Wend
    Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
    Application.ScreenUpdating = True
 
'**********************************************************************************************
 
Case "Edit text within header"
 
'Input text
strFnd = InputBox("Text to Replace", "Old String", "Water Feature Facility")
If strFnd = "" Then Exit Sub
strRep = InputBox("Replacement Text", "New String")
If strRep = "" Then Exit Sub
 
wdStory = Array(wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    On Error Resume Next
    For i = LBound(wdStory) To UBound(wdStory)
      'MsgBox wdStory(i)
      With .StoryRanges(wdStory(i)).Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strFnd
        .Replacement.Text = strRep
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
    Next
    On Error GoTo 0
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
 
'******************************************************************************************
 
Case "Replace footer"
 
   With Application.Dialogs(wdDialogFileOpen)
      If .Show = -1 Then
        Set wdDocSrc = ActiveDocument
      Else
        MsgBox "No Source document chosen. Exiting", vbExclamation
        Exit Sub
      End If
    End With
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
        Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
        AddToRecentFiles:=False, Visible:=False)
        With wdDocTgt
            For Each Sctn In .Sections
                For Each HdFt In Sctn.Footers
                    With HdFt
                        If .LinkToPrevious = False Then
                            .Range.FormattedText = _
                            wdDocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range.FormattedText
                        End If
                    End With
                Next
            Next
            .Close SaveChanges:=True
        End With
                strFile = Dir()
    Wend
    Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
    Application.ScreenUpdating = True
 
'***************************************************************************************
 
Case "Edit text within footer"
 
strFnd = InputBox("Text to Replace", "Old String")
If strFnd = "" Then Exit Sub
strRep = InputBox("Replacement Text", "New String")
If strRep = "" Then Exit Sub
 
wdStory = Array(wdPrimaryFooterStory, wdFirstPageFooterStory, wdEvenPagesFooterStory)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    On Error Resume Next
    For i = LBound(wdStory) To UBound(wdStory)
      'MsgBox wdStory(i)
      With .StoryRanges(wdStory(i)).Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strFnd
        .Replacement.Text = strRep
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
    Next
    On Error GoTo 0
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
 
End Select
 
 
 
End Sub
Private Sub UserForm_Initialize()
 
    cboHFList.AddItem "Replace header"
    cboHFList.AddItem "Edit text within header"
    cboHFList.AddItem "Replace footer"
    cboHFList.AddItem "Edit text within footer"
 
End Sub
 
'Function to select folder where files are found
 
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