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