Sub CopyHyperlink()
Dim Rng As Range
With Selection.Hyperlinks(1).Range.Fields(1)
  Set Rng = .Code
  With .Code
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = False
      .Text = "\l"
      .Replacement.Text = "#"
      .Execute Replace:=wdReplaceAll
      .Text = "HYPERLINK"
      .Replacement.Text = ""
      .Execute Replace:=wdReplaceAll
      .Text = "^w"
      .Execute Replace:=wdReplaceAll
      .Text = Chr(34)
      .Execute Replace:=wdReplaceAll
    End With
  End With
End With
Rng.Copy
While InStr(Rng.Text, "HYPERLINK") = 0
  Undo
Wend
End Sub