Strip e-mail from cell

[Keeper4826]

I have a spreadsheet which has a "User Description" column. In this column, most users have data that looks similar to this:

APPLICATION - john.smith@mycompany.com
APPWEB - jane-doe@somecompany.com
APPWEB - john_doe@othercompany.com
APPLICATION - TP - paul@acompany.com
APP/APPWeb/DEV - paulsm@thecompany.com

There are also cells in this column which literally have a sentence long description, but those are not my focus. What I need to do is find a way to strip out the e-mail address found in the examples above and copy them into a new cell (the same row for the corresponding user). I don't know where to begin for this. Can anybody help?

 

[Keeper4826]

Perhaps:

=TRIM(RIGHT(SUBSTITUTE(A1,"- ",REPT(" ",255)),255))

I tried this. It worked pretty well except for the following example:

App - TP - john@my-company.com

The result is: company.com

 

[Scott Huish]

That would be because in the quotes should be a hyphen then a space (where it is highlighted in blue:

=TRIM(RIGHT(SUBSTITUTE(A1,"- ",REPT(" ",255)),255))

 

[Keeper4826]

That did the trick. Is there a way to further modify the function so that it looks for a "@" qualifier to be stripped out. Here's what I mean. Take a look at the following example:

Service Account for APD APP - : John Smith

Obviously, there is no e-mail address to strip out. However, the existing function will still pull out the following text:

: John Smith

Is there a way to change the code so that it looks for: *@*. If it found something like this, it is more than likely to be an e-mail address to be stripped out. If if does not find this, it should do nothing (leave the cell blank).

 

[erik.van.geit]

That did the trick. Is there a way to further modify the function so that it looks for a "@" qualifier to be stripped out. Here's what I mean. Take a look at the following example:

Service Account for APD APP - : John Smith

Obviously, there is no e-mail address to strip out. However, the existing function will still pull out the following text:

: John Smith

Is there a way to change the code so that it looks for: *@*. If it found something like this, it is more than likely to be an e-mail address to be stripped out. If if does not find this, it should do nothing (leave the cell blank).

try this
  A                                      B                        
1 APPLICATION - no email                                          
2 APPWEB - jane-doe@somecompany.com      jane-doe@somecompany.com 
3 APPWEB - john_doe-at-othercompany.com                           
4 APPLICATION - TP - paul@acompany.com   paul@acompany.com        
5 APP/APPWeb/DEV - paulsm@thecompany.com paulsm@thecompany.com    

Sheet1
[Table-It] version 07 by Erik Van Geit

RANGE FORMULA (1st cell)
B1:B5 =IF(ISNUMBER(SEARCH("@",A1)),TRIM(RIGHT(SUBSTITUTE(A1,"- ",REPT(" ",255)),255)),"")

[Table-It] version 07 by Erik Van Geit

 

[Keeper4826]

I applied the following formula and it worked:

= IF(ISNUMBER(SEARCH("@",E5)),TRIM(RIGHT(SUBSTITUTE(E5,"- ",REPT(" ",255)),255)),"")

I had to apply this to every cell though. I could not find information regarind a "range formula". I did find info regarding an "array formula" which looked similar, if not the same, which would allow me to apply the formula in one cell and to would be applied to an entire range. I couldn't figur out how to make this work though.

How do I take this formula and apply it to a range, or array, as suggested?

 

[Scott Huish]

There is no formula you can put it one cell and have it automatically apply to other cells, what you need is a macro.

This is set to run for the values in Column A and puts the results in Column B, change as necessary. Put all this in a standard module. Run the ExtractEmails macro:

Function GetEmail(r As String) As String
With CreateObject("vbscript.regexp")
    .Pattern = "\s\S+@\S+\.(com|net|edu|org|gov|info)"
    .IgnoreCase = True
    If .test(r) Then GetEmail = Trim(.Execute(r)(0))
End With
End Function

Sub ExtractEmails()
Dim c As Range
For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    c.Offset(, 1) = GetEmail(c.Text)
Next
End Sub

 

[Keeper4826]

Thank you all for your help with this. It has diminished my task load significantly! I've still got a couple more exceptions to resolve, but I think I can take if from here.

I will try the macro HOTPEPPER suggested as an alternative solution. This will help in the future, as I have close to 5400 records to process. I'm still curious about the range formula outlined by erik.van.geit. His code suggests the formula is to be placed in the first cell. In researching his solution, I found an article on array functions which stated in order for it to run properly, I had to enter it user ctrl+shift+enter. After entering the formula and hitting the key combo - nothing happend.

 

[erik.van.geit]

To enter the formula as in my example
select B1
enter formula
copy down to B5

alternatively
select B1:B5 (B1 is activecell)
enter formula
Control+Enter

 

[Keeper4826]

To enter the formula as in my example
select B1
enter formula
copy down to B5

alternatively
select B1:B5 (B1 is activecell)
enter formula
Control+Enter

This is exactly what I did. I just though you had some other secret squirel method of doing this one time, in one cell. I don't know the alternative shortcut you suggested though. Thanks again.

This resolves my issue. Many thanks.

 

[erik.van.geit]

Hotpepper, you too??
We saw posting jindon, then Richard some of this "regular expressions" stuff. Now you too! Still Chinese for me... Where did you learn it?

Why not use it as a sheetfunction?
   A                                          B                         
 1 APPLICATION - john.smith@mycompany.com     john.smith@mycompany.com  
 2 APPWEB - jane-doe@somecompany.com          jane-doe@somecompany.com  
 3 APPWEB - john_doe@othercompany.com         john_doe@othercompany.com 
 4 APPLICATION - TP - paul@acompany.com       paul@acompany.com         
 5 APP/APPWeb/DEV - paulsm@thecompany.com     paulsm@thecompany.com     
 6                                                                      
 7 APPLICATION - john.smith@mycompany.com +++ john.smith@mycompany.com  
 8 APPWEB - jane-doe@somecompany.com other ++ jane-doe@somecompany.com  
 9 APPWEB - john_doe@othercompany.com more    john_doe@othercompany.com 
10 APPLICATION - TP - paul@acompany.com etc   paul@acompany.com         
11 APP/APPWeb/DEV - paulsm@thecompany.com     paulsm@thecompany.com     

WK
[Table-It] version 07 by Erik Van Geit

RANGE   FORMULA (1st cell)
B1:B5   =getemail(A1)
B7:B11  =getemail(A7)

[Table-It] version 07 by Erik Van Geit

We can notice that your function also extracts emailaddresses from the "middle" of the string as you can see in B7:B11.

Yesterday I posted this function, but it seems that it didn't get through

Function email(c As Range)
'Erik Van Geit
'071022

Dim txt As String
Dim l As Long
Dim e As Long
Dim s1 As Long
Dim s2 As Long

txt = c.Text
l = Len(txt)
e = InStr(1, txt, "@")
s1 = l - InStr(l - e, StrReverse(txt), " ") + 1
s2 = InStr(e, txt, " ")
If s2 = 0 Then s2 = l + 1
email = Mid(txt, s1 + 1, s2 - s1)

End Function

   A                                          B                          
 1 APPLICATION - john.smith@mycompany.com     john.smith@mycompany.com   
 2 APPWEB - jane-doe@somecompany.com          jane-doe@somecompany.com   
 3 APPWEB - john_doe@othercompany.com         john_doe@othercompany.com  
 4 APPLICATION - TP - paul@acompany.com       paul@acompany.com          
 5 APP/APPWeb/DEV - paulsm@thecompany.com     paulsm@thecompany.com      
 6                                                                       
 7 APPLICATION - john.smith@mycompany.com +++ john.smith@mycompany.com   
 8 APPWEB - jane-doe@somecompany.com other ++ jane-doe@somecompany.com   
 9 APPWEB - john_doe@othercompany.com more    john_doe@othercompany.com  
10 APPLICATION - TP - paul@acompany.com etc   paul@acompany.com          
11 APP/APPWeb/DEV - paulsm@thecompany.com     paulsm@thecompany.com      

WK
[Table-It] version 07 by Erik Van Geit

RANGE   FORMULA (1st cell)
B1:B11  =email(A1)

[Table-It] version 07 by Erik Van Geit

best regards,
Erik