VBA To Extract Email Address From Text

[Excel Fox]

I'll use a Bazooka here (sorry Rick ), but here's my solution

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