VBA To Extract Email Address From Text

[Rick Rothstein]

An alternative approach, see the attachment

Your code uses spaces as the delimiter which means that for text like this...

testing (jill@gmail.com) this

it returns this...

(jill@gmail.com)

rather than this...

jill@gmail.com

And, of course, it will retain other adjacent non-email-characters as well. If you look at the code I posted, those characters are not retained with the email address itself.

[dunndealpr]

hey Rick. Just tried yours and snb's and they both work, thank you again. What I'm still stumped on is how to make it work for multiple rows at once.

An earlier commenter said "just drag the formula down all the way". Does that mean select all the cells in column B next to the ones you want answers for, and then enter =ExtractEmail(A1:A5) and hit enter? Because when I do that I get #VALUE!

[Rick Rothstein]

hey Rick. Just tried yours and snb's and they both work, thank you again.

Look at Message #23 where I advise that snb's posted function does not remove punctuation marks next to the email address (my guess is you tested his function with a simple text string where the email address stood alone surrounded only be spaces.

What I'm still stumped on is how to make it work for multiple rows at once.

An earlier commenter said "just drag the formula down all the way". Does that mean select all the cells in column B next to the ones you want answers for, and then enter =ExtractEmail(A1:A5) and hit enter? Because when I do that I get #VALUE!

Assuming you have text in A1 to, say, A10, put the formula in B1 and, with B1 selected, hover your cursor over the small black square in the bottom right corner of B1 (the selected cell) until the cursor becomes what looks like a plus sign, then click and drag down to B10... the address references in the formula will automatically adjust for their new location. You can achieve the same result by selecting B1 (after you put the formula in it), copying it, then selecting B1:B10 and pasting.

[dunndealpr]

Holy cow. It works! I cannot thank you guys enough. I hope you're rich.

Thank you again.

[Excel Fox]

For posterity, the 'bazooka' function uses a heavy-duty regular expression (it was Rick who coined it that way in one of our threads, so I'll pass the credit to him for the catchy name).

Just for the record though, the function that I posted (revised one below) will extract more than one email address from the string, should it contain that many.

Function ExtractEmail(strInputText As String) As String

    Dim regEx As Object
    Dim varResults As Object
    Dim varEach
    Dim lng As Long
    With CreateObject("vbscript.RegExp")
    .Pattern = "(?:[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\.[a-z0-9!#$%&'*+/=?^_`{|}~-]+)*|""(?:[\x01-\x08\x0b\x0c\x0e-\x1f\x21\x23-\x5b\x5d-\x7f]|\\[\x01-\x09\x0b\x0c\x0e-\x7f])*"")@(?:(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:[a-z0-9-]*[a-z0-9])?|\[(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?|[a-z0-9-]*[a-z0-9]:(?:[\x01-\x08\x0b\x0c\x0e-\x1f\x21-\x5a\x53-\x7f]|\\[\x01-\x09\x0b\x0c\x0e-\x7f])+)\])"
    .IgnoreCase = True 'True to ignore case
    .Global = True 'True matches all occurances, False matches the first occurance
    If .Test(strInputText) Then
        Set varResults = .Execute(strInputText)
        For lng = 1 To varResults.Count
            ExtractEmail = ExtractEmail & varResults.Item(lng - 1).Value & "|||"
        Next
        ExtractEmail = Left(ExtractEmail, Len(ExtractEmail) - Len("|||"))
        ExtractEmail = Join(Split(ExtractEmail, "|||"), ", ")
    End If
    End With
End Function

[Rick Rothstein]

Just for the record though, the function that I posted (revised one below) will extract more than one email address from the string, should it contain that many.

Excellent idea Excel Fox! Here is my code modified to do the same thing...

Function GetEmailAddress(Sin As String) As String
  Dim X As Long, AtSign As Long, AtSign2 As Long, StartAt As Long, S As String, subS As String
  Dim Locale As String, Domain As String
  Locale = "[A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]"
  Domain = "[A-Za-z0-9._-]"
  StartAt = 1
  Do
    S = Mid(Sin, StartAt)
    AtSign = InStr(StartAt, S, "@")
    If AtSign < 2 Then Exit Do
    If Mid(S, AtSign - 1, 1) Like Locale Then
      For X = AtSign To 1 Step -1
        If Not Mid(" " & S, X, 1) Like Locale Then
          subS = Mid(S, X)
          If Left(subS, 1) = "." Then subS = Mid(subS, 2)
          Exit For
        End If
      Next
      AtSign2 = InStr(subS, "@")
      For X = AtSign2 + 1 To Len(subS) + 1
        If Not Mid(subS & " ", X, 1) Like Domain Then
          subS = Left(subS, X - 1)
          If Right(subS, 1) = "." Then subS = Left(subS, Len(subS) - 1)
          GetEmailAddress = GetEmailAddress & ", " & subS
          Exit For
        End If
      Next
    End If
    StartAt = AtSign + 1
  Loop
  GetEmailAddress = Mid(GetEmailAddress, 3)
End Function

[snb]

I assumed the OP had email addresses in sentences, so I assumed every email address being encapsulated by spaces. Based on his feedback I conclude my assumption was correct.
So I won't try to match Rick's 'overkill' () code. Sufficient is enough I'd say

[Rick Rothstein]

I assumed the OP had email addresses in sentences, so I assumed every email address being encapsulated by spaces. Based on his feedback I conclude my assumption was correct.

From the OP's posting in Message #3...

"Add to that, a lot of people I know don't exactly follow proper writing rules, so there might be a character pressed right up against the beginning or the end of their email address with no space. A lot of people end the sentence with their email address, meaning there's a period at the end of .com."

[Rick Rothstein]

I assumed the OP had email addresses in sentences, so I assumed every email address being encapsulated by spaces. Based on his feedback I conclude my assumption was correct.

By the way, if you are correct and the OP's email addresses are separated by spaces, and if (and this is a big if) the email address will always come before any other text (Twitter or whatever) with an asterisk, and ignoring the fact the OP said he wanted a VBA solution, there is a formula solution to be had...

=TRIM(RIGHT(SUBSTITUTE(LEFT(A1,FIND("@",A1)-1)," ",REPT(" ",500)),500))&MID(A1,FIND("@",A1),FIND(" ",A1&" ",FIND("@",A1))-FIND("@",A1))

[dunndealpr]

I've also noticed the 'extractemail' code is missing quite a few emails. I've attached a document with three examples of text it was unable to extract emails from. Any ideas?