I have written a Macro to update text in multiple DOCX files, however it will not update the Footer. I have templates to evaluations, and I need to make a Rev change to all of them at once. Can anyone update the following Macro to Search and replace text in the Footer?:

Sub Update_DOCX_File_Sigs()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, DOCXDoc
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.DOCX", vbNormal)
While strFile <> ""
Set DOCXDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With DOCXDoc.Range.Find
.ClearFormatting
.Text = "72-0006-3500/8"
.Replacement.Text = "72-0006-3500/9"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
DOCXDoc.Close SaveChanges:=True
strFile = Dir()
Wend
Set DOCXDoc = 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

Attached Files

Macro.txt (1.1 KB, 12 views)