extract email addresses from two column list

A

ajm

Well-known Member
Joined
Feb 5, 2003
Messages
2,053
Office Version
  1. 365
Platform
  1. Windows
hi, i am trying to extract email addresses from a two column list. looks like the information may have been copied and pasted from a business card application of some sort. so first column contains name and a few other bits and pieces, the second column contains email address, phone numbers, status etc. unfortunately some records seem to be six lines, some seven. i thought i might try using a pivot to create a list of the account names and then do a lookup/offset combination formula but i cannot seem to work into it the means to locate the "@" in the email address (to identify which line contains the email address). my end result will be two columns: name and email address. or maybe, since the name is already on the first line of each record, i could use some sort of formula to pull the email address up the first line of column c??

<!-- Please do not remove this header -->
<!-- Table easily created from Excel with ASAP Utilities (ASAP Utilities for Excel - The essential add-in for Excel users. FREE excel tools and macros to save time. Download Excel tools) -->
<table border="1" bordercolor="#C0C0C0" bordercolordark="#FFFFFF" cellspacing="0" cellpadding="2">
<tr>
<td bgcolor="#FFFFFF" valign="bottom" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">Celebrant</font></td>
<td bgcolor="#FFFFFF" valign="bottom" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">Details</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">Abbey*Dayrell, Ms</font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">12 Battunga Street, Wishart QLD 4122</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#00BB00">Registered</font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">p(H):*(07) 3349 3236*</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"><b>13/01/2010</b></font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">p(W):*(07) 3864 0221*</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#BB0000">Active</font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">m:*0414 359 154</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" align="right" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"></font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#0000FF"><u>abbeyd27@bigpond.com</u></font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" align="right" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"></font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"><b>Civil Ceremonies</b></font></td>
</tr>
<tr>
<td bgcolor="#FCF8ED" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">Abbott*Timothy, Mr</font></td>
<td bgcolor="#FCF8ED" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">8 Warattah Court, Wurtulla QLD 4575</font></td>
</tr>
<tr>
<td bgcolor="#FCF8ED" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#00BB00">Registered</font></td>
<td bgcolor="#FCF8ED" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">p(H):*(07) 5309 5070*</font></td>
</tr>
<tr>
<td bgcolor="#FCF8ED" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"><b>26/02/2010</b></font></td>
<td bgcolor="#FCF8ED" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">p(W):*(07) 5440 2000*</font></td>
</tr>
<tr>
<td bgcolor="#FCF8ED" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#BB0000">Active</font></td>
<td bgcolor="#FCF8ED" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">m:*0400 988 191</font></td>
</tr>
<tr>
<td bgcolor="#FCF8ED" align="right" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"></font></td>
<td bgcolor="#FCF8ED" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#0000FF"><u>kerriabbott@optusnet.com.au</u></font></td>
</tr>
<tr>
<td bgcolor="#FCF8ED" align="right" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"></font></td>
<td bgcolor="#FCF8ED" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"><b>Civil Ceremonies</b></font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">Aberdeen*Leonie, Mrs</font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">13 Lowanna Tce, Cleveland QLD 4163</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#00BB00">Registered</font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">p(H):*07 3821 0025*</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"><b>2/09/2008</b></font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000">m:*0411 032 250</font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" valign="middle" style="white-space: nowrap"><font face="Tahoma" size="2" color="#BB0000">Active</font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#0000FF"><u>leonie.aberdeen@bigpond.com</u></font></td>
</tr>
<tr>
<td bgcolor="#FFFFFF" align="right" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"></font></td>
<td bgcolor="#FFFFFF" valign="top" style="white-space: nowrap"><font face="Tahoma" size="2" color="#000000"><b>Civil Ceremonies</b></font></td>
</tr>
</table>
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
ajm,


Sample raw data in worksheet Sheet1:


Excel Workbook
AB
1CelebrantDetails
2Abbey*Dayrell, Ms12 Battunga Street, Wishart QLD 4122
3Registeredp(H):*(07) 3349 3236*
413/01/2010p(W):*(07) 3864 0221*
5Activem:*0414 359 154
6abbeyd27@bigpond.com
7Civil Ceremonies
8Abbott*Timothy, Mr8 Warattah Court, Wurtulla QLD 4575
9Registeredp(H):*(07) 5309 5070*
1026/02/2010p(W):*(07) 5440 2000*
11Activem:*0400 988 191
12kerriabbott@optusnet.com.au
13Civil Ceremonies
14Aberdeen*Leonie, Mrs13 Lowanna Tce, Cleveland QLD 4163
15Registeredp(H):*07 3821 0025*
162/9/2008m:*0411 032 250
17Activeleonie.aberdeen@bigpond.com
18Civil Ceremonies
19
Sheet1





Is this the results you are looking for in worksheet Restuls?


Excel Workbook
ABCDEFGHIJKLM
1CelebrantMr Ms MrsRegisteredDateActiveStreetCity?Zipp(H):p(W):m:E-mail
2Dayrell AbbeyMsRegistered13/01/2010Active12 Battunga StreetWishartQLD4122(07) 3349 3236(07) 3864 02210414 359 154abbeyd27@bigpond.com
3Timothy AbbottMrRegistered26/02/2010Active8 Warattah CourtWurtullaQLD4575(07) 5309 5070(07) 5440 20000400 988 191kerriabbott@optusnet.com.au
4Leonie AberdeenMrsRegistered2/9/2008Active13 Lowanna TceClevelandQLD416307 3821 00250411 032 250leonie.aberdeen@bigpond.com
5
Results





If the above screenshot is not correct, please supply a screenshot of what worksheet Results should look like.
 
Upvote 0
The attached will get you all e-mails in Column C, except for the LAST Entry in Column A & B (Do Manually...?)

With your sheet set up as follows:


Excel 2010
ABC
1CelebrantDetailse-mail Only
2Abbey*Dayrell, Ms12 Battunga Street, Wishart QLD 4122
3Registeredp(H):*(07) 3349 3236*
413/01/2010p(W):*(07) 3864 0221*
5Activem:*0414 359 154
6abbeyd27@bigpond.com
7Civil Ceremonies
8Abbott*Timothy, Mr8 Warattah Court, Wurtulla QLD 4575
9Registeredp(H):*(07) 5309 5070*
1026/02/2010p(W):*(07) 5440 2000*
11Activem:*0400 988 191
12jmay@cox.net
13Civil Ceremonies
14Aberdeen*Leonie, Mrs13 Lowanna Tce, Cleveland QLD 4163
15Registeredp(H):*07 3821 0025*
162/9/2008m:*0411 032 250
17Activeleonie.aberdeen@bigpond.com
18Civil Ceremonies
Sheet1


Run this Macro...

Code: 
Sub convertToEmail()
    Dim convertRng As Range, Rng As Range
    Dim LR as long
    LR = Range("B" & Rows.Count).End(xlUp).Row
    Set convertRng = Range("C2:C" & LR)
    With convertRng
        .Formula = "=(IF(AND(A8<>"""",A7=""""),OFFSET(A8,-2,1),""""))"
        For Each Rng In convertRng
        
    If InStr(1, Rng.Value, "@", vbTextCompare) Then
            ActiveSheet.Hyperlinks.Add Rng, "mailto:" & Rng.Value
        End If
    Next Rng
    End With
    'Change the range to suit your need.

End Sub
 
Last edited:
Upvote 0
Excel Workbook
ABCDE
1CelebrantDetailsNameEmail
2Abbey*Dayrell, Ms12 Battunga Street, Wishart QLD 4122Abbey*Dayrell, Msabbeyd27@bigpond.com
3Registeredp(H):*(07) 3349 3236*Abbott*Timothy, Mrkerriabbott@optusnet.com.au
413/01/2010p(W):*(07) 3864 0221*Aberdeen*Leonie, Mrsleonie.aberdeen@bigpond.com
5Activem:*0414 359 154
6abbeyd27@bigpond.com
7Civil Ceremonies
8Abbott*Timothy, Mr8 Warattah Court, Wurtulla QLD 4575
9Registeredp(H):*(07) 5309 5070*
1026/02/2010p(W):*(07) 5440 2000*
11Activem:*0400 988 191
12kerriabbott@optusnet.com.au
13Civil Ceremonies
14Aberdeen*Leonie, Mrs13 Lowanna Tce, Cleveland QLD 4163
15Registeredp(H):*07 3821 0025*
162/9/2008m:*0411 032 250
17Activeleonie.aberdeen@bigpond.com
18Civil Ceremonies
Sheet1
 
Upvote 0
ajm,


Sample raw data in worksheet Sheet1:


Excel Workbook
AB
1CelebrantDetails
2Abbey*Dayrell, Ms12 Battunga Street, Wishart QLD 4122
3Registeredp(H):*(07) 3349 3236*
413/01/2010p(W):*(07) 3864 0221*
5Activem:*0414 359 154
6abbeyd27@bigpond.com
7Civil Ceremonies
8Abbott*Timothy, Mr8 Warattah Court, Wurtulla QLD 4575
9Registeredp(H):*(07) 5309 5070*
1026/02/2010p(W):*(07) 5440 2000*
11Activem:*0400 988 191
12kerriabbott@optusnet.com.au
13Civil Ceremonies
14Aberdeen*Leonie, Mrs13 Lowanna Tce, Cleveland QLD 4163
15Registeredp(H):*07 3821 0025*
162/9/2008m:*0411 032 250
17Activeleonie.aberdeen@bigpond.com
18Civil Ceremonies
19
Sheet1





After the macro in a new worksheet Results:


Excel Workbook
ABCDEFGHIJKLM
1CelebrantMr Ms MrsRegisteredDateActiveStreetCity?Zipp(H):p(W):m:E-mail
2Dayrell AbbeyMsRegistered13/01/2010Active12 Battunga StreetWishartQLD4122(07) 3349 3236(07) 3864 02210414 359 154abbeyd27@bigpond.com
3Timothy AbbottMrRegistered26/02/2010Active8 Warattah CourtWurtullaQLD4575(07) 5309 5070(07) 5440 20000400 988 191kerriabbott@optusnet.com.au
4Leonie AberdeenMrsRegistered2/9/2008Active13 Lowanna TceClevelandQLD416307 3821 00250411 032 250leonie.aberdeen@bigpond.com
5
Results





Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.


Code: 
Option Explicit
Sub ExtractData()
' hiker95, 11/18/2012
' http://www.mrexcel.com/forum/excel-questions/670029-extract-email-addresses-two-column-list.html
Dim w1 As Worksheet, wR As Worksheet
Dim c As Range, firstaddress As String
Dim r As Long, lr As Long, nr As Long, sr As Long, er As Long
Dim Area As Range, s, t
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
With wR.Cells(1, 1).Resize(, 13)
  .Value = [{"Celebrant","Mr Ms Mrs","Registered","Date","Active","Street","City","?","Zip","p(H):","p(W):","m:","E-mail"}]
  .Font.Bold = True
  .HorizontalAlignment = xlCenter
End With
With w1.Columns(2)
  Set c = .Find("Civil Ceremonies", LookIn:=xlValues, LookAt:=xlWhole)
  If Not c Is Nothing Then
    firstaddress = c.Address
    Do
      w1.Rows(c.Row + 1).Insert
      Set c = .FindNext(c)
    Loop While Not c Is Nothing And c.Address <> firstaddress
  End If
End With
For Each Area In w1.Range("B2", w1.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
  With Area
    sr = .Row
    er = sr + .Rows.Count - 1
    nr = wR.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    s = Split(w1.Cells(sr, 1), ", ")
    wR.Cells(nr, 2) = s(1)
    t = Split(s(0), "*")
    wR.Cells(nr, 1) = t(1) & " " & t(0)
    wR.Cells(nr, 3).Resize(, 3).Value = Application.Transpose(w1.Range("A" & sr + 1 & ":A" & sr + 3).Value)
    For r = sr To er - 1 Step 1
      If InStr(w1.Cells(r, 2), ", ") > 0 Then
        s = Split(w1.Cells(r, 2), ", ")
        wR.Cells(nr, 6) = s(0)
        t = Split(s(1), " ")
        wR.Cells(nr, 7).Resize(, 3).Value = t
      ElseIf InStr(w1.Cells(r, 2), "p(H):") > 0 Then
        s = Split(w1.Cells(r, 2), "*")
        wR.Cells(nr, 10) = s(1)
      ElseIf InStr(w1.Cells(r, 2), "p(W):") > 0 Then
        s = Split(w1.Cells(r, 2), "*")
        wR.Cells(nr, 11) = s(1)
      ElseIf InStr(w1.Cells(r, 2), "m:") > 0 Then
        s = Split(w1.Cells(r, 2), "*")
        wR.Cells(nr, 12) = s(1)
      ElseIf InStr(w1.Cells(r, 2), "@") > 0 Then
        wR.Cells(nr, 13) = w1.Cells(r, 2)
      End If
    Next r
  End With
Next Area
On Error Resume Next
w1.Range("B1", w1.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
wR.Cells.EntireColumn.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub


Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ExtractData macro.
 
Upvote 0
thanks everybody for you responses. I am going to go with hiker's solution.

Hiker, i am getting a subscript out of range error. on this line; wR.Cells(nr, 1) = t(1) & " " & t(0)][/B]
 
Upvote 0
ajm,

Hiker, i am getting a subscript out of range error. on this line; wR.Cells(nr, 1) = t(1) & " " & t(0)]
Click to expand...

That would lead me to believe that one of the Celebrant name cells in column A is different than the data you have posted.

Can you give us a screenshot of the raw data in worksheet Sheet1 where the name field may not contain a last and first name?


Or, can we see your workbook, worksheet Sheet1?

You can upload your workbook to Box Net,
sensitive data scrubbed/removed/changed
mark the workbook for sharing
and provide us with a link to your workbook.
 
Upvote 0
how about hyphenated names? either first names: (for eg)Ann-Marie, Kylie-Ann, etc or Last Names, eg Adrian-walla. apart form that sort of thing, I can see nothing other than Active, Registered, and the date, as shown in the sample. I am unable to access box.net from work so will try to get a names list up there tonight.. thanks for persisting with this.
 
Upvote 0
I noticed that there is one in there also that has a space in the surname eg "John Le Lastname" where Le Lastname is the surname. i will try to find it again.
 
Upvote 0
ajm,

I need to see screenshots, like your original post, of the different groups of data that do not conform to the data in your original screenshot, from Celebrant to Civil Ceremonies.

And, in the cell where you have Wishart QLD 4122, what is the description/title for QLD?
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
import specific columns from one workbook to another from matching header with vba
Replies
1
Views
81
Peter_SSs
Peter_SSs
D
  • Solved
VBA Function to Paste Table into Outlook Email Resulting in HTML language in Email
Replies
8
Views
554
smozgur
smozgur
C
  • Question Question
Adding Image to email
Replies
1
Views
213
plettieri
P
E
  • Question Question
VBA code clean up
Replies
9
Views
510
mumps
mumps
C
  • Solved
Excel 2016 32bit VBA Pulling info from Website to Sheet
Replies
2
Views
1K
CrashOD
C

Forum statistics

Threads
1,223,710
Messages
6,174,019
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top