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?.
brothertruffle880Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

aikimarkCommented:
please post a sample document that represents the type of document you have in production.
0
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.
interested-students.docx
0
aikimarkCommented:
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
    Loop
    Application.Documents.Add
    For Each vItem In colEmailAddrs
        ActiveDocument.Content.InsertAfter vItem & vbCrLf
    Next
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Word

From novice to tech pro — start learning today.