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