Sub SearchAndReplace()
    Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
    Dim sFolder As String, strFilePattern As String
    Dim strFileName As String, sFileName As String
    Dim strFind, strRep, strSearchList, strRepList As String
    Dim i, x As Long
    Dim lngValidate As Long
    Dim oShp As Shape

    'Application.ScreenUpdating = False
    
    strSearchList = "DATE \@, MERGEFIELD Company Name,(IN LIQUIDATION),MERGEFIELD ACN,MERGEFIELD Trading_Name,MERGEFIELD Trust"
    strRepList = "[RF_TODAY_LONG],[RF_ADMIN_FULL_NAME],[RF_ADMIN_APPT_SUFFIX],[RF_JOBINFO_A.C.N.],[RF_JOBINFO_FORMERLY_TRADING_AS],[RF_JOBINFO_ TRUST_NAME],[RF_JOBINFO_A.B.N.]"

    'Use to select folder
    'sFolder = GetFolder & "\"

    '~~> Change this to the folder which has the files (or comment and use GetFolder)
    sFolder = "S:\TEMPLATES\APL Precedents\CVL\"
    '~~> This is the file extension you want to loop through
    strFilePattern = "*.dotx"

    '~~> Establish an Word application object
    On Error Resume Next
    Set oWordApp = GetObject(, "Word.Application")

    If Err.Number <> 0 Then
        Set oWordApp = CreateObject("Word.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oWordApp.Visible = True

    '~~> Loop through the folder to get the word files
    strFileName = Dir$(sFolder & strFilePattern)
    Do Until strFileName = ""
        sFileName = sFolder & strFileName

        '~~> Open the word doc
        Set oWordDoc = oWordApp.Documents.Open(sFileName)

        oWordDoc.ActiveWindow.View.ShowFieldCodes = True
        
        'Convert merge fileds to text
        'oWordDoc.Fields.Unlink

        'Fix the skipped blank Header/Footer problem.
        lngValidate = oWordDoc.Sections(1).Headers(1).Range.StoryType
        
        'Iterate through all story types in the current document.
        For Each rngStory In oWordDoc.StoryRanges
        
            '~~> Iterate through all linked stories. Do Find and Replace.
            Do
                For i = 0 To UBound(Split(strSearchList, ","))
                    strFind = Split(strSearchList, ",")(i)
                    strRep = Split(strRepList, ",")(i)
                    ReplaceFields rngStory, strFind, strRep
                    SearchAndReplaceInStory rngStory, strFind, strRep
                Next
                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
                                    For x = 0 To UBound(Split(strSearchList, ","))
                                        strFind = Split(strSearchList, ",")(x)
                                        strRep = Split(strRepList, ",")(x)
                                        ReplaceFields rngStory, strFind, strRep
                                        SearchAndReplaceInStory oShp.TextFrame.TextRange, strFind, strRep
                                    Next
                                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

        '~~> Close the file after saving
        oWordDoc.Close SaveChanges:=True

        '~~> Find next file
        strFileName = Dir$()
    Loop
    
    'Application.ScreenUpdating = true

    '~~> Quit and clean up
    oWordApp.Quit

    Set oWordDoc = Nothing
    Set oWordApp = Nothing
End Sub

Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)

    rngStory.TextRetrievalMode.IncludeFieldCodes = True
    rngStory.TextRetrievalMode.IncludeHiddenText = True

    With rngStory.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Text = strSearch
        .Replacement.Text = strReplace
        .Execute Replace:=wdReplaceAll
    End With
    
lbl_Exit:
  Exit Sub
End Sub

Sub ReplaceFields(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 25 Sep 2018
'Modified by me

    Dim oFld As Field

    For Each oFld In rngStory.Fields
        If oFld.Type = wdFieldMergeField Or oFld.Type = wdFieldDate Or oFld.Type = wdFieldIf Then
            If InStr(1, oFld.Code, strSearch) > 0 Then
                oFld.Code.Text = Replace(oFld.Code.Text, strSearch, strReplace)
                oFld.Update
                oFld.Unlink
            End If
        End If
    Next oFld
    
lbl_Exit:
    Set oFld = Nothing
    Exit Sub
    
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 ReplaceFields(ByVal rngStory As Word.Range, ByVal strSearch As String, ByVal strReplace As String)

    Dim oFld As Field
    Dim oRng As Range
    
    For Each oFld In ActiveDocument.Fields
        Set oRng = oFld.Code
        If InStr(1, oRng.Text, strSearch) > 0 Then
        oRng.MoveStart wdCharacter, -1
        oRng.Collapse
        oRng.InsertAfter strReplace
        oFld.Delete
        End If
    Next oFld
    
lbl_Exit:
    Set oFld = Nothing
    Set oRng = Nothing
    Exit Sub
    
End Sub