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