Macro to extract all of the email addresses from a document

Sub CopyAddressesToOtherDoc()

  Dim Source As Document, Target As Document, myRange As Range
   Set Source = ActiveDocument
   Set Target = Documents.Add

Application.ScreenUpdating = False

   Source.Activate
   Selection.HomeKey Unit:=wdStory
   Selection.Find.ClearFormatting
   With Selection.Find
Do While .Execute(findText:="[+0-9A-z._-]{1,}\@[A-z.]{1,}", _
MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
           Set myRange = Selection.Range
           Target.Range.InsertAfter myRange & vbCr
       Loop
   End With

Selection.HomeKey Unit:=wdStory
Target.Activate

End Sub