Sub Loop_AllWordFiles_inFolder()
'macro created by Michelle Peters August 12, 2022
'Optimize Macro Speed
Application.ScreenUpdating = False
Dim strDocNm As String, strFolder As String, strFile As String, wdDoc As Document
Dim strFind As String, strRplc As String
Dim strWildCrd As Integer
'Have user enter the search and replace strings and if there are wildcards
    strFind = InputBox("Enter your search string and use wildcards if necessary.")
    strRplc = InputBox("Enter your replace string and use wildcards if necessary.")
    strWildCrd = MsgBox("Do either your search or replace string contain wildcard characters?", vbQuestion + vbYesNo + vbDefaultButton2, "Wildcards")
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
strDocNm = ThisDocument.FullName
While strFile <> ""
    If strFolder & " \ " & strFile <> strDocNm Then
        Set wdDoc = Documents.Open(FileName:=strFolder & " \ " & strFile, AddToRecentFiles:=False, Visible:=True)
    With wdDoc
      Call FindReplaceAnywhere(wdDoc, strFind, strRplc, strWildCrd)
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
MsgBox "Finished scanning all files in Folder " & Path
Set wdDoc = 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

Sub FindReplaceAnywhere(wDoc As Document, ByVal strFind As String, ByVal strRplc As String, ByVal strWildCrd As Integer)
'macro created by Michelle Peters March 18, 2022
'macro created to loop through all stories in Word to replace text
Dim rngStory As Word.Range
Dim lngValidate As Long
Dim oShp As Shape
  'Fix the skipped blank header/footer problem
  lngValidate = wDoc.Sections(1).Headers(1).Range.StoryType
  'Iterate through all stroy types in the current document
  For Each rngStory In wDoc.StoryRanges
    'Iterate through all linked stories
    Do
      If strWildCrd = vbYes Then
      SearchandReplaceWild rngStory, strFind, strRplc
      Else
      SearchandReplaceInStory rngStory, strFind, strRplc
      End If
      On Error Resume Next
      Select Case rngStory.StoryType
        Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
                For Each oShp In rngStory.ShapeRange
                If oShp.TextFrame.HasText Then
                    If strWildCrd = vbYes Then
                    SearchandReplaceWild oShp.TextFrame.TextRange, strFind, strRplc
                    Else
                    SearchandReplaceInStory oShp.TextFrame.TextRange, strFind, strRplc
                    End If
                End If
            Next
        End If
        Case Else
            'do Nothing
        End Select
    On Error GoTo 0
    'get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
    Next
    wDoc.BuiltInDocumentProperties(wdPropertyComments) = strRplc
lbl_exit:
    Exit Sub
End Sub

Sub SearchandReplaceInStory(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)
       With rngStory.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strSearch
        .Replacement.Text = strReplace
        .Wrap = wdFindContinue
        .MatchWildcards = False
        .Execute Replace:=wdReplaceAll
      End With
lbl_exit:
    Exit Sub
End Sub

Sub SearchandReplaceWild(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)
    With rngStory.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strSearch
        .Replacement.Text = strReplace
        .Wrap = wdFindContinue
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
lbl_exit:
End Sub