|Here's a VBA method of extracting both email addresses, based on your example.|
The code works as follows:
1 - It uses TextToColumns to place each word in the original cell into individual cells.
2 - It then searches through the individual cells looking for cells that contain both an @ sign and a "dot" (period). It then assumes that that is an email address. We could harden that up by searching for an @ sign plus a (.com or .net or .edu or .org) etc.
3 - When it finds an @ and a dot it copies that cell to Sheet2 Column A.
4 - If the 'suspected" email address ends in a period (like the one in your example) the code strips off the period.
It works for your example, but may need some tweaking if some of the text in the cells is laid out differently.
Note: The code assumes the following:
- The cells with the original text begin in Sheet1!A1
- The rest of that row is empty and available for the TextToColumns function to do it's job
- Sheet2 Column A is available to accept the copied email addresses.
Let me know what you think.
Dim lastTxtRow, nxtRow, nxtCol, lastTxtCol, nxtAddyRow As Integer
'Determine last row of text in Sheet1, Column A
lastTxtRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Loop through Column A
For nxtRow = 1 To lastTxtRow
'Split text into individual cells
Sheets(1).Cells(nxtRow, 1).TextToColumns _
Destination:=Sheets(1).Cells(nxtRow, 2), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
'Determine last column in current Row
lastTxtCol = Sheets(1).Cells(nxtRow, Columns.Count).End(xlToLeft).Column
'Loop through current Row, looking for @ sign
For nxtCol = 2 To lastTxtCol
If Sheets(1).Cells(nxtRow, nxtCol) Like "*@*" And _
Sheets(1).Cells(nxtRow, nxtCol) Like "*.*" Then
'If found, determine next empty Row on Sheet2
nxtAddyRow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
'Copy email address to Sheet2
Sheets(1).Cells(nxtRow, nxtCol).Copy Destination:=Sheets(2).Cells(nxtAddyRow, 1)
'Check for Period at end of email address, strip off if found
If Right(Sheets(2).Cells(nxtAddyRow, 1), 1) = "." Then
Sheets(2).Cells(nxtAddyRow, 1) = _
Left(Sheets(2).Cells(nxtAddyRow, 1), Len(Sheets(2).Cells(nxtAddyRow, 1)) - 1)
'Loop and work on next cell