Find email addresses and move to new column?

I have all of my data in one column with email addresses scattered throughout. I want to pick all of these email addresses out (most likely search for "@" signs) and move them to their own column. Please help!

Find email addresses and move to new column?
Here's a function that works when the address items are separated by at least one space (and'or a comma). An email address is returned, or null if no "@" symbol is found.





Any commas are removed from the email address by the replace function





Function FindEmail(strData)


聽 Dim strEmail As String


聽 Dim Found as Boolean





聽 x = Split(strData)


聽 Found = False


聽


聽 For i = UBound(x) To 0 Step -1


聽 聽 If InStr(x(i), "@") %26lt;%26gt; 0 Then


聽 聽 聽 strEmail = x(i)


聽 聽 聽 Found = true


聽 聽 聽 Exit For


聽 聽 End If


聽 Next i





聽 If (Found) Then


聽 聽 FindEmail = Trim(Replace(strEmail, ",", ""))


聽 Else


聽 聽 FindEmail = ""


聽 End If





End Function





If your data is in column A, starts in row 1, then enter the formula





=FindEmail(A1) and drag fill in your desired column