Update Multiple Documents Footer

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

[gmayor]

The reason it doesn't update the footer is that your macro doesn't address the footer. It addresses only the main storyrange i.e. DOCXDoc.Range. If you want to address all the ranges in a document, or specific ranges, you need to loop through all the storyranges or address the specific range. The following takes the former approach. You might also be interested in http://www.gmayor.com/document_batch_processes.htm which has built-in processes to handle this including the sub foilders of the selected folder if required.

Option Explicit

Sub Update_DOCX_File_Sigs()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, DOCXDoc
    Dim oStory As Range
    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)
        For Each oStory In DOCXDoc.StoryRanges
            ReplaceInRange oStory
            If oStory.StoryType <> wdMainTextStory Then
                While Not (oStory.NextStoryRange Is Nothing)
                    Set oStory = oStory.NextStoryRange
                    ReplaceInRange oStory
                Wend
            End If
        Next oStory
        DOCXDoc.Close SaveChanges:=True
        strFile = Dir()
    Wend
    Set oStory = Nothing
    Set DOCXDoc = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub ReplaceInRange(oRng As Range)
    With oRng.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
End Sub

Private 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

Worked Perfectly, thanks a heap