Sub URLshrinker()
' Paul Beverley - Version 15.07.23
' Reduces the extent of a URL link to just the selected text

If Selection.Start = Selection.End Then
  Selection.Expand wdWord
  Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
  DoEvents
  Loop
End If
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False

Set rng = Selection.Range.Duplicate
' Find the beginning and end of the existing link
Do
  rng.MoveStart , -1
  DoEvents
  Debug.Print rng.Font.Underline
Loop Until rng.Font.Underline > 1
Do
  rng.MoveEnd , 1
  DoEvents
  Debug.Print rng.Font.Underline
Loop Until rng.Font.Underline > 1
myCode = rng.Fields(1).Code
myCode = Replace(myCode, "HYPERLINK", "")
myCode = Replace(myCode, """", "")
rng.Fields(1).Unlink
Set newLink = ActiveDocument.Hyperlinks.Add(Anchor:=Selection.Range, _
         Address:=myCode)
ActiveDocument.TrackRevisions = myTrack
End Sub