Word 2010 - VBA - Extracting email addresses from a document

I have a document which I would like to extract the email addresses from and place them in a new document each email address on its own line.  Each email address ending with a hard return. The document contains email addresses embedded throughout the text interspersed with regular text (resume data).

What is the code that can perform this?.
Who is Participating?
aikimarkConnect With a Mentor Commented:
It looks like you have some broken/invalid email addresses in the document you posted.  The last two lines contain email addresses that contain a space character.

Option Explicit

Public Sub Q_28242815()
    Dim colEmailAddrs As New Collection
    Dim vItem As Variant
    Dim rng As Range
    Dim strFound As String
    Set rng = ActiveDocument.Content
    rng.Find.Execute findtext:="^w^p", replacewith:="^p", Replace:=wdReplaceAll
    Do While rng.Find.Execute(findtext:=" ([! ]@)^13", Forward:=True, MatchWildcards:=True) = True
        strFound = Trim(Left(rng.Text, Len(rng.Text) - 1))
        If strFound Like "*@*.*" Then
            colEmailAddrs.Add strFound
        End If
    For Each vItem In colEmailAddrs
        ActiveDocument.Content.InsertAfter vItem & vbCrLf
End Sub

Open in new window

please post a sample document that represents the type of document you have in production.
brothertruffle880Author Commented:
Here is an example of one type of document I'd like to extract email address from and place into a separate document.

There are also resumes too.  But you already know what a resume looks like.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.