Option Base 1
Dim HyperlinkArray()' Dimension array to contain hyperlinks
Public Sub Main()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
On Error GoTo BYE
Dim Count as Integer
Count = 0
Btn = MsgBox("This macro will copy the hyperlinks from the current." & vbCrLf & _
            " document into a new document." & vbCrLf & vbCrLf & _
            " Do you WISH TO PROCEED?", vbYesNo + vbQuestion, _
            " Startup Message")
If Btn = vbNo Then Exit Sub
Selection.HomeKey Unit:=wdStory' Go to the top of the document
OUTERLOOP:
With Selection.Find
    .Text = "<a href"' Find the start of the hyperlink
    .Replacement.Text = ""
    .MatchWildcards = False
    .Format = False
    .Wrap = wdFindStop
    .Forward = True
End With
Selection.Find.Execute
If Selection.Find.Found Then
    Selection.ExtendMode = True' Set extension mode to true
    With Selection.Find
        .Text = ">"' Finding the end of the hyperlink.
        .Replacement.Text = ""
        .MatchWildcards = False
        .Format = False
        .Wrap = wdFindStop
        .Forward = True
    End With
    Selection.Find.Execute
    Selection.ExtendMode = False' Turn the extension mode off
    Pos = InStr(Selection.Text, Chr(34))
    Pos2 = InStr(Pos + 1, Selection.Text, Chr(34))
    MyTemp = Mid(Selection.Text, Pos + 1, Pos2 - (Pos + 1))
    Count = Count + 1
    ReDim Preserve HyperlinkArray(Count)' Dynamically resizing the array
    HyperlinkArray(Count) = MyTemp
    Selection.START = Selection.End
    GoTo OUTERLOOP
Else
    GoTo ARRAY_FEED
End If
ARRAY_FEED:
Documents.Add Template:="", NewTemplate:=False' Adding a new document
For i = 1 To UBound(HyperlinkArray())' Looping through our array
    Selection.InsertAfter Text:=HyperlinkArray(i) & Chr(13)' Inserting the hyperlinks
    Selection.START = Selection.End
Next
BYE:
Selection.ExtendMode = False
Selection.HomeKey Unit:=wdStory' Returning to the top of the document.
Btn = MsgBox("There were" & Str(Count) & " hyperlinks extracted to the 2nd document.", _
            vbOKOnly + vbInformation, _
            " Final Results")
End Sub