Extract Email Addresses from strings in Range to new Range

[DeonM]

I have a sheet with text in a range in column B. The text in each cell can include none or multiple email addresses. I want to extract the first found email address in each cell in the range and copy it to column T (in the same row as the source).

I have found this Function at http://spreadsheetpage.com/index.php/tip/extracting_an_email_address_from_text/ for extracting the emails.

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._-]"
    
    [COLOR=#0000FF]'Get location of the @[/COLOR]
    AtSignLocation = InStr(s, "@")
    If AtSignLocation = 0 Then
        ExtractEmailAddress = "" 'not found
    Else
        TempStr = ""
        [COLOR=#0000FF]'Get 1st half of email address[/COLOR]
        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
        [COLOR=#0000FF]'get 2nd half[/COLOR]
        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
    [COLOR=#0000FF]'Remove trailing period if it exists[/COLOR]
    If Right(TempStr, 1) = "." Then TempStr = _
       Left(TempStr, Len(TempStr) - 1)
    ExtractEmailAddress = TempStr
End Function

It works perfectly for extracting the first email as I want. But I have had no success in converting the Function into a Sub that will loop through the source range and copy it to column T.

Any help or pointers much appreciated.

 

[cooper645]

does it have to be done in VBA? you could use the following formula in T1 and drag down:

=TRIM(RIGHT(SUBSTITUTE(LEFT(B1,FIND(" ",B1&" ",FIND("@",B1))-1)," ",REPT(" ",LEN(B1))),LEN(B1)))

 

[cooper645]

or if you really want to use VBA then this should do just the job,

Sub ExtractFirstEmail()
Dim PosAt As Integer, PosBeg As Integer, PosEnd As Integer, AddLen As Integer
Dim i  As Integer, Lrow As Long
On Error Resume Next
    Lrow = Cells(Rows.Count, "B").End(xlUp).Row
        For i = [COLOR=#ff0000]1[/COLOR] To Lrow
            PosAt = InStr(1, Cells(i, 2), "@", vbBinaryCompare)
            PosBeg = InStrRev(Cells(i, 2), " ", PosAt, vbBinaryCompare) + 1
            PosEnd = InStr(PosAt, Cells(i, 2), " ", vbBinaryCompare)
                If PosEnd = 0 Then
                    PosEnd = Len(Cells(i, 2))
                Else
                    PosEnd = PosEnd - 1
                End If
            AddLen = PosEnd - PosBeg + 1
            Cells(i, 20).Value = Mid(Cells(i, 2), PosBeg, AddLen)
        Next i
End Sub

you will need to amend the 1 to whichever is the first row that you wish to start extracting from

 

[DeonM]

Thanks for the reply. It must be VBA. It's part of a much greater macro.

You code works basically but the email addresses in the source strings are not always preceded or ended by spaces. Often they have other characters or line returns, or full stops etc. immediately before or after the email address. I presume that's why the function code uses the " Const CharList As String = "[A-Za-z0-9._-]" " to correctly extract the emails.

I've tried to make that work with your code... but it's above my skill level.

The first quoted function is the only one of many I tried that really extracts the email addresses without any extraneous characters. And I need that further along in the routine.

 

[cooper645]

Just use the UDF you put in the first message. then add the following into your code (or simply use 'Call Copyemail' within your code at the point you wish to extract the email addresses)

Don't forget to amend the 1 to the row number you wish to start from

Sub Copyemail()
Dim i As Integer, Lrow As Long
Lrow = Cells(Rows.Count, "B").End(xlUp).Row
For i = [COLOR=#ff0000]1[/COLOR] To Lrow
    Cells(i, 20).Value = ExtractEmailAddress(Cells(i, 2))
Next i
End Sub

 

[DeonM]

Thanks. That's exactly what I was trying to get - using the function in my sub. I could just not figure out the right syntax for the "Cells(i, 20).Value = ExtractEmailAddress(Cells(i, 2))". Works perfectly.

For my interest and learning: both the function and the sub uses the i variable (simultaneously) but it doesn't seem to matter - it still works. Why is this?

 

[cooper645]

I'm not 100% sure, but I think that its possibly the equivalent of say brackets, so the UDF calculates what it needs to, then the sub routine calculates as it needs to, but if your concerned, change one to a j or whatever. I use i as it seems logical to me that I is short for integer, and also the material I first started out reading would likely have had an influence (John walkenbachs material)