Identify and separate email IDs

[vilas desai]

Hello Experts,

I col A (starting from A2 upto A5000) I have a mix of texts lines and embedded in this text is a email ID. I would like to identify these email IDs using
an identifier as '@' followed by .XXX (such as .com or .net etc) and have these email IDs listed in col B
Example is as below

Best regards
Vilas Desai

COL A
Accumulators Inc
1175 Brittmoore Rd, Houston, TX 77043-5003,
Jeff Ramsey, Sls Mgr, 713-465-0202,
info@accumulators.com,
www.accumulators.com
ACCUSONIC
259 Samuel Barnet Blvd, Unit 1,
New Bedford, MA 02745, Rob Shone,
Sr App Eng, 256-430-3366,
accusonicsales@idexcorp.com,
www.accusonic.com
ACM Composites
Derwent Way, Wath upon Dearne S63 6EX,
UK, 44-1709-874-951,
sales@acmbearings.co.uk,
www.acmbearings.co.uk
ACR Systems Inc
15110-54A Ave, Suite 201, Surrey, BC V3S 5X7,
Canada, Juliette Sicotte, Territory Sls Mgr,
604-591-1128, sales@acrsystems.com,
www.acrsystems.com
Adams Schweiz
Austr 49, Zurich, ZH 8045, Switzerland,
Andreas Roos, Mgr Sls/Mktg,
41-44-461-54-15, info@adams-armaturen.ch,
www.adams-armaturen.ch
Alfa Star Hydro Ltd
305 King St W, Suite 1010, Kitchener, ON
N2G 1B9, Canada, Robert Tjandra, Pres/CEO,
519-804-9530, info@alfastarhydro.com,
www.alfastarhydro.com
Allied Industrial Marketing
W62 N248 Washington Ave, Suite 208,
Cedarburg, WI 53012, John Houdek, Pres,
262-618-2403,
info@alliedindustrialmarketing.com,
www.alliedindustrialmarketing.com
Alltech Engineering Corp
2515 Pilot Knob Rd, Mendota Heights, MN
55120, Andy Lawrence, Pres, 651-452-7893,
alawrence@alltechengineering.com,
www.alltechengineering.com (Ad on Pg 97)

[HansV]

Run this macro:

Code: Select all

Sub ExtractEmailAddresses()
    Dim c As Range
    Dim t As Long
    Dim s As String
    Dim v As String
    Dim a() As String
    Dim i As Long
    Application.ScreenUpdating = False
    With Range("A:A")
        Set c = .Find(What:="@", LookAt:=xlPart)
        If Not c Is Nothing Then
            s = c.Address
            Do
                v = Replace(c.Value, Chr(160), "")
                a = Split(v, ",")
                For i = 0 To UBound(a)
                    If InStr(a(i), "@") > 0 Then
                        t = t + 1
                        Range("B" & t).Value = Trim(a(i))
                        Exit For
                    End If
                Next i
                Set c = .FindNext(After:=c)
                If c Is Nothing Then Exit Do
            Loop Until c.Address = s
        End If
    End With
    Application.ScreenUpdating = True
End Sub

[Doc.AElstein]

Hello vilas
Another way, ( I started doing it before Hans posted, so I thought I might as well finish it as an alternative. )
This might work for you
_ Copy your range to the clipboards,
_ Get the text string out of the Windows clipboard
_ Split that into an array of the rows of data.
_Now go through the array elements and pick out the ones based on some criteria, do a bit of tyding the line up, then putting them into a string from which you can make an output array…
_ etc…


The macro below will get you started for an Email list in column B : http://i.imgur.com/dXaCNZG.jpg

Code: Select all

Option Explicit
Sub vilasEMails() '  https://eileenslounge.com/viewtopic.php?p=279890#p279890
Dim StrText As String
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")   '     http://web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/

' Put the range in clipboards
ActiveSheet.Range("A1:A42").Copy

' get range text out of (some bit of window probably) clipboard
objDataObject.GetFromClipboard
 Let StrText = objDataObject.GetText() ' : Debug.Print StrText
                                                                                                                                     '  Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(StrText)
' Split text into an array of the rows of data
Dim arrRws() As String: Let arrRws = Split(StrText, vbCr & vbLf, -1, vbBinaryCompare)

' go through the array elements and pick out the ones based on some criteria
Dim strOut As String
Dim Cnt As Long
    For Cnt = 0 To UBound(arrRws())
        If InStr(1, arrRws(Cnt), "@", vbBinaryCompare) <> 0 Then
        Dim strLne As String
         Let strLne = Replace(arrRws(Cnt), ",", "", 1, 2, vbBinaryCompare)  ' get rid of any commas
            If InStr(1, strLne, " ", vbBinaryCompare) <> 0 Then Let strLne = Split(strLne, " ", 2)(1) ' if there is a space, I assume that means there is a number entry before the EMail, so split the two entries and take the second entry
         Let strOut = strOut & strLne & vbCr & vbLf ' put the EMail address into a string for output
        Else
        End If
    Next Cnt
 Let strOut = Left(strOut, Len(strOut) - 2) ' Take off the last   vbCr & vbLf

' Output
Dim arrOut() As String
 Let arrOut() = Split(strOut, vbCr & vbLf, -1, vbBinaryCompare)
Dim arrOutT() As Variant ' For transposed array
 Let arrOutT() = Application.Index(arrOut(), Evaluate("=Row(1:" & UBound(arrOut()) + 1 & ")/Row(1:" & UBound(arrOut()) + 1 & ")"), Evaluate("=Row(1:" & UBound(arrOut()) + 1 & ")"))
 Let ActiveSheet.Range("B1:B" & UBound(arrOutT(), 1) & "").Value = arrOutT()
End Sub

Alan

[vilas desai]

Thanks a lot Hans and Doc