Option Explicit

Sub ReplaceFromTableWithFormatting()


' Slightly Tweaked from Graham Mayor's TableReplace Function
' And  Doug Robbins
' Bulk Find & Replace From Table
'

Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range, rReplacement As Range
Dim i As Long
Dim sFname As String

    '==================DOCUMENT LOCATION


    sFname = "C:\Users\Desktop\TableReplace.docx"
    
    Set oDoc = ActiveDocument
    Set oChanges = Documents.Open(Filename:=sFname, Visible:=False)
    Set oTable = oChanges.Tables(1)
    For i = 1 To oTable.Rows.Count
        Set oRng = oDoc.Range
        Set rFindText = oTable.Cell(i, 1).Range
        rFindText.End = rFindText.End - 1
        Set rReplacement = oTable.Cell(i, 2).Range
        rReplacement.End = rReplacement.End - 1
        Selection.HomeKey wdStory

        With oRng.Find
            ' Find only the exact formatted version as displayed in Column 1
            '.Format = True        ' This may not be correct?
            '.ClearFormatting
            '.Replacement.ClearFormatting
            'set the variety of formats to look for
            .Font.Name = rFindText.Font.Name
            .Font.Bold = rFindText.Font.Bold
            .Font.Size = rFindText.Font.Size
            .Font.Italic = rFindText.Font.Italic
            .Font.Underline = rFindText.Font.Underline
            .Font.ColorIndex = rFindText.Font.ColorIndex
            
            Do While .Execute(FindText:=rFindText, _
                              MatchWholeWord:=True, _
                              MatchWildcards:=False, _
                              Forward:=True, _
                              Wrap:=wdFindStop) = True
'                oRng.Select
                oRng.FormattedText = rReplacement.FormattedText
                oRng.Collapse wdCollapseEnd
            Loop
        End With

    Next i
    oChanges.Close wdDoNotSaveChanges
End Sub