VBA To Extract Email Address From Text

[Rick Rothstein]

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.

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