I guess something like

Sub Macro1()'Graham Mayor - https://www.gmayor.com - Last updated - 29 May 2019
Dim oRng As Range
Dim i As Integer
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Highlight = True
        Do While .Execute
            oRng.Font.Underline = wdUnderlineNone
            oRng.NoProofing = True
            i = Len(oRng)
            oRng.InsertAfter oRng.Text
            oRng.MoveEnd Count:=i
            oRng.Characters(i + 1).Underline = wdUnderlineSingle
            For i = i To 1 Step -1
                oRng.Characters(i).Font.Hidden = True
            Next i
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub
should work