VBA To Extract Email Address From Text

**dunndealpr** · 06-07-2013, 02:47 AM

**Rick Rothstein** · 06-07-2013, 04:57 AM

Originally Posted by dunndealpr

The text surrounding the emails is always different (ie the emails are not surrounded by <> or any other kind of constant characters that can simplify this).

**dunndealpr** · 06-07-2013, 11:14 AM

Originally Posted by Rick Rothstein

It has to be surrounded by something in order to be able to tell where it begins or ends... give us an idea of the type of characters you see on either side of it so we can get an idea how to proceed.

**Rick Rothstein** · 06-07-2013, 11:38 AM

Give the following function a try. The first argument is the text string to parse and the optional second argument allows you to start the search from an arbitrary location within the text. If the function finds the first @ sign after the StartAt value (optional, defaulted to 1) and if that @ sign is not part of an email address, then the function returns the empty string. You will need to set up a loop that starts looking one character after each @ sign until it finds a valid email address.

Code:

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

**Excel Fox** · 06-07-2013, 12:11 PM

I'll use a Bazooka here (sorry Rick

), but here's my solution

Code:

Function ExtractEmail(strInputText As String) As String

    Dim regEx As Object
    Dim varResults As Object
    Dim varEach
    Dim lng As Long
    Set regEx = CreateObject("vbscript.RegExp")
    regEx.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])+)\])"
    regEx.IgnoreCase = True 'True to ignore case
    regEx.Global = True 'True matches all occurances, False matches the first occurance
    If regEx.Test(Range("D1").Value) Then
        Set varResults = regEx.Execute(Range("D1").Value)
        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 Function

**Excel Fox** · 06-07-2013, 12:13 PM

By the way, the pattern I used was from here (not my invention)

How to Find or Validate an Email Address

**Rick Rothstein** · 06-07-2013, 12:49 PM

Originally Posted by Excel Fox

By the way, the pattern I used was from here (not my invention)

How to Find or Validate an Email Address

And [gulp] one hell of a pattern it is...

**dunndealpr** · 06-07-2013, 01:41 PM

Hey all. Thanks so much for your time here. I saved the bazooka script as a macro and ran it, but I got a 'compile error: unexpected end sub' prompt. It seems when I created a macro called 'rickroth', Excel has added 'sub Rickroth' at the top of the code.

Sorry if I'm making a silly mistake here. I'm adept enough at using VBA script in Word but for some reason it eludes me in Excel.

**Rick Rothstein** · 06-07-2013, 01:59 PM

Originally Posted by dunndealpr

Hey all. Thanks so much for your time here. I saved the bazooka script as a macro and ran it, but I got a 'compile error: unexpected end sub' prompt. It seems when I created a macro called 'rickroth', Excel has added 'sub Rickroth' at the top of the code.

I am not sure what you are saying here.... the code Excel Fox and I posted are not macros, they are functions meant to be called by other code (macros, event, etc.) or used as a function within a worksheet formula. Please explain exactly what you did and what happened when you did it.

**dunndealpr** · 06-07-2013, 02:04 PM

Originally Posted by Rick Rothstein

I am not sure what you are saying here.... the code Excel Fox and I posted are not macros, they are functions meant to be called by other code (macros, event, etc.) or used as a function within a worksheet formula. Please explain exactly what you did and what happened when you did it.

currently browsing Excel 2007 For Dummies for a tutorial on how to insert this script properly. I know I should really know this kind of thing before coming to you guys, but if you can hit me with a link that explains how to do this, it would save me a lot of hair today. Sorry.