Extract Mail Address from String

Here is what I need to happen.

I have this text (1000's of them, but same format) in a column:

Tim Queen (tim.queen.jrtd@crazymail.com)

I need to remove the name "Tim Queen" from the beginning and remove the "(" & ")". I want to be left with just the email address.

How can I do this for 1000's of names at one time?

Hi

Assuming your email in A1 try:

=TRIM(MID(SUBSTITUTE(SUBSTITUTE(A1,"(",REPT(" ",100)),")",REPT(" ",100)),100,100))

and copy down.

Richard

fastrack1,

Your post does not comply with Rule 1 of our Forum RULES. Your post title should accurately and concisely describe your problem, not your anticipated solution. Use terms appropriate to a Google search. Poor thread titles, like Please Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will be addressed according to the OP's experience in the forum: If you have less than 10 posts, expect (and respond to) a request to change your thread title. If you have 10 or more posts, expect your post to be locked, so you can start a new thread with an appropriate title.
To change a Title on your post, click EDIT then Go Advanced and change your title, if 2 days have passed ask a moderator to do it for you.

On this occasion I have modified for you - going forward please endeavour to follow the above guidelines.

hi all,

Here's a little something I've been playing with recently to help extract emails from messy database dumps which may have the emails in a number of separate columns etc.

It is "work in progress" & needs to be optimised (esp the Redim within a loop & perhaps to use a paramarray) but I thought I would post it "as is" since it ties in with the subject of this thread (thanks to DO's editing)

Option Explicit
Public Function ExtractEmailAddresses(rng As Range) As String
'9/12/2009, sourced (& then modified) from: http://spreadsheetpage.com/index.php/site/tip/extracting_an_email_address_from_text/
    Dim AtSignLocation As Long
    Dim i As Long
    Dim j As Long
    Dim TempStr As String
    Const CharList As String = "[A-Za-z0-9._-]"
    Dim s As String
    Const EmlDivider As String = ", "
    Dim cll As Range
    Dim AtSymblsIndx As Long
    Dim AtSymblsCnt As Long
    Dim AtSymblsCnt2 As Long
    Dim nodupes As New Collection
    Dim Swap1, Swap2, Item
    Dim iniString As String
    Dim FinalString As String
    Dim TempStr1 As String
    Dim tempstr2 As String
    For Each cll In rng
        s = cll.Value
        AtSymblsCnt = UBound(Split(s, "@"))
        AtSignLocation = 0
        For AtSymblsIndx = 1 To AtSymblsCnt
            'Get location of the @
            AtSignLocation = InStr(Right(s, Len(s) - (AtSignLocation)), "@")
            If AtSignLocation = 0 Then
                Exit For
            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 Stop: 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
            'ori            If Right(TempStr, 1) = "." Then TempStr = Left(TempStr, Len(TempStr) - 1)
            If Right(TempStr, 1) = "." Then TempStr = Left(TempStr, Len(TempStr) - 1)
            TempStr1 = TempStr1 & IIf(Right(TempStr1, Len(EmlDivider)) <> EmlDivider, EmlDivider, "") & TempStr
        Next AtSymblsIndx
    Next cll
AddedSection:        '#######
    AtSymblsCnt2 = UBound(Split(TempStr1, "@"))
    Dim EmlAddressesArr As Variant
    EmlAddressesArr = Split(TempStr1, EmlDivider, -1)        'minus 1 is Optional (added by me)
    For i = LBound(EmlAddressesArr) To UBound(EmlAddressesArr)
        'Stop
        On Error Resume Next
        If Trim(EmlAddressesArr(i)) <> "" Then nodupes.Add Trim(EmlAddressesArr(i)), Trim(EmlAddressesArr(i))
        '          Note: the 2nd argument (key) for the Add method must be a string
        '      Resume normal error handling
        On Error GoTo 0
    Next i
    '                    '   Sort the collection (optional)
    '                For i = 1 To nodupes.Count - 1
    '                    For j = i + 1 To nodupes.Count
    '                        If nodupes(i) > nodupes(j) Then
    '                            Swap1 = nodupes(i)
    '                            Swap2 = nodupes(j)
    '                            nodupes.Add Swap1, Before:=j
    '                            nodupes.Add Swap2, Before:=i
    '                            nodupes.Remove i + 1
    '                            nodupes.Remove j + 1
    '                        End If
    '                    Next j
    '                Next i
    Dim nwArr As Variant
    '   Delete existing items in list, add the sorted, non-duplicated items back to a new array for transfer to the cell
    For i = 0 To nodupes.Count - 1
        Select Case i
        Case Is > 0
            ReDim Preserve nwArr(i)
        Case Is = 0
            ReDim nwArr(i)
        End Select
        nwArr(i) = nodupes.Item(i + 1)
    Next i
    If Not IsEmpty(nwArr) Then
        FinalString = Join(nwArr, EmlDivider)
    Else
        FinalString = "= N/A: No Email addresses in the selected range!"
    End If
EndAddedSection:        '#######
    ExtractEmailAddresses = FinalString
End Function

hth
Rob