Sub URLlinker()
' Paul Beverley - Version 14.04.22
' Finds all URLs in the text and links them

charsInURLs = "[%./:a-zA-Z0-9_\-\?^38=+]"

Set rng = ActiveDocument.Range
myFind = "<[wthps]{3,5}>" & charsInURLs & "{1,}"
With rng.Find
  .Text = myFind
  .Replacement.Text = ""
  .Wrap = wdFindStop
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

Do While rng.Find.Found = True
  rng.Select
  Selection.Collapse wdCollapseStart
  stNow = Selection.Start
  Selection.MoveLeft , 1
  stBefore = Selection.Start
  If stNow = stBefore + 1 Then
    myAddress = rng.Text
    rng.Text = Replace(rng.Text, "https://", "")
    rng.Text = Replace(rng.Text, "http://", "")
    rng.Select
    Set myLink = ActiveDocument.Hyperlinks.Add(Anchor:=rng, _
          Address:=myAddress, TextToDisplay:=rng.Text)
    rng.Start = myLink.Range.End
    rng.End = ActiveDocument.Content.End
  Else
    rng.Start = rng.End
  End If
  rng.Find.Execute
  DoEvents
Loop
Beep
End Sub