an error is occurring, the Macro will not open and edit the Headers or Footers, but it does the body - could someone review and see if i have the correct code for editing Headers and Footers (in pink)


Private Sub FindAndReplace_docx(oFolder As String)
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, wdDoc As Document
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
Dim xlFList As String, xlRList As String, i As Long, Rslt
StrWkBkNm = "\\it17.local\root\UserData\munwil\My Documents\My Documents\Projects\IMS Structure Change\Find and Replace.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
'Get the folder to process
strFolder = oFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
' Record that we've started Excel.
bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
'Hide our Excel session
If bStrt = True Then .Visible = False
For Each xlWkBk In .Workbooks
If xlWkBk.FullName = StrWkBkNm Then ' It's open
Set xlWkBk = xlWkBk
bFound = True
Exit For
End If
Next
' If not open by the current user.
If bFound = False Then
' Check if another user has it open.
If IsFileLocked(StrWkBkNm) = True Then
' Report and exit if true
MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
If bStrt = True Then .Quit
Exit Sub
End If
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
If bStrt = True Then .Quit
Exit Sub
End If
End If
' Process the workbook.
With xlWkBk.Worksheets(StrWkSht)
' Find the last-used row in column A.
' Add 1 to get the next row for data-entry.
iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
' Output the captured data.
For i = 1 To iDataRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList = xlFList & "|" & Trim(.Range("A" & i))
xlRList = xlRList & "|" & Trim(.Range("B" & i))
End If
Next
End With
If bFound = False Then xlWkBk.Close False
If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Process each document in the folder
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
Options.DefaultHighlightColorIndex = wdPink
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
'process Headers with Find and Replace Function
For Each Sctn In wdDoc.Sections
For Each HdFt In Sctn.Headers
With HdFt
If .LinkToPrevious = False Then
'Process the header
With .Range.Find
'Find and Replace parameters for Headers
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
For Each Shp In wdDoc.Shapes
With Shp.TextFrame
If .HasText Then
With .TextRange.Find
'Process each word from the F/R List within Headers which has Shapes
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
End If
End With
Next
End If
End With
Next
Next
'Process Footers with Find and Replace Function
For Each Sctn In wdDoc.Sections
For Each HdFt In Sctn.Headers
With HdFt
If .LinkToPrevious = False Then
With .Range.Find
'Find and Replace parameters for Footers
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
For Each Shp In wdDoc.Shapes
With Shp.TextFrame
If .HasText Then
With .TextRange.Find
'Process each word from the F/R List within Footers which has Shapes
For i = 1 To UBound(Split(xlFList, "|"))
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
End With
End With
Next
End With
End If
End With
Next
End If
End With
Next
Next
'Close the document
wdDoc.Close SaveChanges:=True
'Get the next document
strFile = Dir()
Wend
Application.ScreenUpdating = True
End Sub