Have a vba code that extracts the email address from a string. Can it be modified to exclude a list of email address?

The below code works great, but sometimes the target email address is not the first one in the string. There are 2 email addresses that are a constantly ahead of the target email address that I want to skip/exclude from the search.

Function ExtractEmailAddress(s As String) As String
    Dim AtSignLocation As Long
    Dim i As Long
    Dim TempStr As String
    Const CharList As String = "[A-Za-z0-9._-]"
    
    'Get location of the @
    AtSignLocation = InStr(s, "@")
    If AtSignLocation = 0 Then
        ExtractEmailAddress = "" 'not found
    Else
        TempStr = ""
        'Get 1st half of email address
        For i = AtSignLocation - 1 To 1 Step -1
            If Mid(s, i, 1) Like CharList Then
                TempStr = Mid(s, i, 1) & TempStr
            Else
                Exit For
            End If
        Next i
        If TempStr = "" Then Exit Function
        'get 2nd half
        TempStr = TempStr & "@"
        For i = AtSignLocation + 1 To Len(s)
            If Mid(s, i, 1) Like CharList Then
                TempStr = TempStr & Mid(s, i, 1)
            Else
                Exit For
            End If
        Next i
    End If
    'Remove trailing period if it exists
    If Right(TempStr, 1) = "." Then TempStr = _
       Left(TempStr, Len(TempStr) - 1)
    ExtractEmailAddress = TempStr
End Function

Open in new window

kbay808Asked: 2015-03-05

Who is Participating?

LVL 55

Rgonzo1971Commented: 2015-03-05

Hi,

pls try ( with reference to Microsoft VBScript Regular Expressions)

Function ExtractEmailAddress(s As String) As String
    Dim regEx As New RegExp
    Dim strPattern As String
    Dim strInput As String
    Dim strReplace As String
    Dim strOutput As String
    
    
    strPattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"

    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = strPattern
    End With
    Set Matches = regEx.Execute(s)
    If Matches.Count > 1 Then
        Select Case Matches(0)
            Case "aa@aa.com", "bb@bb.com"
                Res = Matches(1)
            Case Else
                Res = Matches(0)
        End Select

    ElseIf Matches.Count = 1 Then
        Res = Matches(0)
    Else ' 0
        Res = ""
    End If
ExtractEmailAddress = Res
End Function

Open in new window

you can change the unwanted emails on line 20

Regards

LVL 38

KimputerCommented: 2015-03-05

Can you give a few of these input strings, what the current output is, what you like the output to be? If it returns an empty string, is the original code (that calls this function) able to handle it?

LVL 12

FarWestCommented: 2015-03-05

you can put this code at the beginning of your function, it will remove the emails from that you want to ignore from the parameter variable

    'processing emails to be ommited
    
       Dim oEmails() As String
        oEmails = Split("oemail1.mmm.com;/oemai2.cmmc.com;", "/")
       Dim ioc As Integer
       For ioc = 1 To UBound(oEmails)
       s = Replace(s, oEmails(ioc), "")
      Next

Open in new window

Good Luck

kbay808Author Commented: 2015-03-05

@Rgonzo1971 – Thanks, your code works a lot better than the one I was using.

@FarWest – I can’t get you code to exclude either email. Please see the example that I attached.
Email-Extract-Example.xlsm

LVL 12

FarWestCommented: 2015-03-05

try this, I've tested it and it is ok
' remove ";" from oemails string
'counter ioc started from 0 not 1

   Dim oEmails() As String
    oEmails = Split("AB_Service_Account@yahoo.com/ABC_CustomerSatisfaction@yahoo.com", "/")
    Dim ioc As Integer
    For ioc = 0 To UBound(oEmails)
    s = Replace(s, oEmails(ioc), "")
    Next

Open in new window

kbay808Author Commented: 2015-03-05

@Rgonzo1971 – I got so excited that your code was doing such a better job extracting all of the emails that I forgot to modify it for exclude the 2 that I did not want. Your code works perfect!!!
@FarWest – Your code works perfect too.
Thank you both very much.