Microsoft Office Forums - View Single Post - [Solved] Update Multiple Documents Footer

gmayor · 08-19-2015, 01:47 AM

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.

Code:

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