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