Hi Norie,
OK, thanks for that programming tip. I will look up the split function.
When I look at the data, I find that the email address is as follows:
E-mail: [email protected] I would l
32 32 32 32 69 45 109 97 105 108 58 32 114 99 99 49 49 53 52 57 64 109 115 110 46 99 111 109 32 32 32 32 73 32 119 111 117 108 100 32 108
So, there are spaces before the email address and spaces after. I don't find any Chr(10)'s. There is one space after "E-Mail". There are also spaces (4) after the email address.
So, I rewrote the code as follows:
Sub ExtractEmails()
Dim RowCounter As Double
Dim ColCounter As Double
Dim MaxRow As Double
Dim SearchString As String
Dim SearchMatch As String
Dim EmailAddress As String
Dim StartEmailChar As Integer
Dim EndEmailChar As Integer
Dim LengthofName As Integer
Range("A2").Activate
'Place cursor in first cell to have email extracted
RowCounter = ActiveCell.Row
ColCounter = ActiveCell.Column + 1
'Insert Maxrow value
MaxRow = 14
For RowCounter = 1 To MaxRow - 1
SearchString = Cells(RowCounter, ColCounter)
If SearchString <> "" Then
SearchChar = "E-mail:"
StartEmailChar = InStr(1, SearchString, SearchChar, 1) + 8
EndEmailChar = InStr(StartEmailChar, SearchString, " ", 1)
LengthofName = EndEmailChar - StartEmailChar
'LengthofName = 7
EmailAddress = Mid(SearchString, StartEmailChar, EndEmailChar - StartEmailChar)
Cells(MaxRow + RowCounter, ColCounter) = EmailAddress
End If
Next RowCounter
End Sub
And, it WORKS!, sort of.
In the answer field, I get the email address surrounded by quotes, as in:
"Theemailaddress.com"
So, I added the code to remove the " at the beginning and the " at the end.
But, I still get the quotes at the ends of the field.
Here is the new code:
Sub ExtractEmails()
Dim RowCounter As Double
Dim ColCounter As Double
Dim MaxRow As Double
Dim SearchString As String
Dim SearchMatch As String
Dim EmailAddress As String
Dim StartEmailChar As Integer
Dim EndEmailChar As Integer
Dim LengthofName As Integer
Dim LengthEmail As Integer
Range("A2").Activate
'Place cursor in first cell to have email extracted
RowCounter = ActiveCell.Row
ColCounter = ActiveCell.Column + 1
'Insert Maxrow value
MaxRow = 9
For RowCounter = 1 To MaxRow
SearchString = Cells(RowCounter, ColCounter)
If SearchString <> "" Then
SearchChar = "E-mail:"
StartEmailChar = InStr(1, SearchString, SearchChar, 1) + 8
EndEmailChar = InStr(StartEmailChar, SearchString, " ", 1)
LengthofName = EndEmailChar - StartEmailChar
'LengthofName = 7
EmailAddress = Mid(SearchString, StartEmailChar, EndEmailChar - StartEmailChar)
LengthEmail = Len(EmailAddress)
Cells(MaxRow + RowCounter + 1, ColCounter) = Right(Left(EmailAddress, LengthEmail - 2), LengthEmail - 2)
End If
Next RowCounter
End Sub
Bookmarks