Email from Specific Term

Blessy Clara

Board Regular
Joined
Mar 28, 2010
Messages
201
Hi

I have an excel sheet with Columns Running from 1 to 150 - First row is header

Example
Col1Col2Col....Col120Col130Col150
principal@alphass.eq.edu.au0517_PandC@eq.edu.auEQInternational@dete.qld.gov.aunmcca106@eq.edu.auaccounts@helpinghandsnetwork.com.au
the.principal@wondaiss.eq.edu.auadmin@wondaiss.eq.edu.auInternationalStudy@murrumbassc.eq.edu.auUniformShop@tannsandss.eq.edu.au
the.principal@redlynchsc.eq.edu.au/principal@redlyncsc.eq.edu.au
oakleighoshc@gmail.comthe.principal@nundahss.eq.edu.au

<tbody>
</tbody>

I want to pull out emails with specific terms - Example Principal Email

Col1Col2Col....Col120Col130Result
principal@alphass.eq.edu.au0517_PandC@eq.edu.auEQInternational@dete.qld.gov.aunmcca106@eq.edu.auaccounts@helpinghandsnetwork.com.auprincipal@alphass.eq.edu.au
the.principal@wondaiss.eq.edu.auadmin@wondaiss.eq.edu.auInternationalStudy@murrumbassc.eq.edu.auUniformShop@tannsandss.eq.edu.au
the.principal@wondaiss.eq.edu.au


<tbody>
</tbody>
the.principal@redlynchsc.eq.edu.au/principal@redlyncsc.eq.edu.authe.principal@redlynchsc.eq.edu.au/principal@redlyncsc.eq.edu.au
oakleighoshc@gmail.comthe.principal@nundahss.eq.edu.au
the.principal@nundahss.eq.edu.au


<tbody>
</tbody>

<tbody>
</tbody>

Thank you in advance
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Where do you want to put them?
It can be in column A of another sheet

Try this macro, change the data in red for your data.

Code:
Sub pull_email()


    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim j As Long, r As Range, b As Range, celda As String, specific As String
    
    Set sh1 = Sheets("[B][COLOR=#ff0000]Sheet1[/COLOR][/B]")
    Set sh2 = Sheets("[B][COLOR=#ff0000]Sheet2[/COLOR][/B]")
    specific = "[B][COLOR=#ff0000]Principal[/COLOR][/B]"
    
    
    sh2.Cells.ClearContents
    j = 2
    
    Set r = sh1.Cells
    Set b = r.Find(specific, LookAt:=xlPart, LookIn:=xlValues)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            'detalle
            sh2.Cells(j, "A").Value = b.Value
            j = j + 1
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If
    MsgBox "End"
    
End Sub

Let me know if you have any doubt.
 
Upvote 0
I'm glad to help you. I appreciate your kind comments.
 
Upvote 0
Hi DanteAmor

One more specificity - I want to retain the ID number of the email row
example - if ID number 5 is blank and 6 has an email i want it to be pulled as per ID - so 5 is blank in result and 6 has the email ...kindaa

This code has given me all the principal emails but i am unable to match from which Org the email has been pulled - so could you please help me with that - Sorry for having missed this point
 
Upvote 0
You can put examples explaining what you need, maybe you can upload an image or your file to the cloud.
There you explain with detail what you need.

You could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.
 
Upvote 0
https://www.dropbox.com/s/f9p16rdn2xine3c/Email_Split.xlsx?dl=0

Hi DanteAmor Thanks for the Guidance - This is the Link to the Data Sample

Sample = How the data looks
Result = this is how i require the Data

Basically from all the 200+ columns I want to extract or pull only Principal Emails
I want the ID Number for the respective Email - so that i can merge the extracted Principal Emails with the Main database
 
Last edited:
Upvote 0
Use this

Code:
Sub pull_email()


    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim j As Long, r As Range, b As Range, celda As String, specific As String
    
    Set sh1 = Sheets("Sample")
    Set sh2 = Sheets("Result")
    specific = "Principal"
    
    sh2.Cells.ClearContents
    sh1.Columns("A:B").Copy sh2.Range("A1")
    
    Set r = sh1.Range("B2", sh1.Cells(Rows.Count, Columns.Count))
    Set b = r.Find(specific, LookAt:=xlPart, LookIn:=xlValues)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            'detalle
            If sh2.Cells(b.Row, "B").Value = "" Then
                sh2.Cells(b.Row, "B").Value = b.Value
            End If
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If
    MsgBox "End"
    
End Sub
 
Upvote 0
Hi DanteAmor

Thank you - If I change specific = "Principal" this line to admin or any other term will i be able to use this code for other specific terms as required ?
If i want to pull out all emails containing the term admin or info ?

What must I do to modify the code so that i can use it as stated above

I tried for Keyword - Principal - It was absolutely great - when i changed the key term to info or admin i am not getting the specific emails but principal emails are also getting mixed - Could you please advise
 
Upvote 0
Use this

Code:
Sub pull_email()


    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim j As Long, r As Range, b As Range, celda As String, specific As String
    
    Set sh1 = Sheets("Sample")
    Set sh2 = Sheets("Result")
    specific = "info"
    
    sh2.Cells.ClearContents
    sh1.Columns("A").Copy sh2.Range("A1")
    sh2.Range("B1").Value = specific
    
    Set r = sh1.Range("B2", sh1.Cells(Rows.Count, Columns.Count))
    Set b = r.Find(specific, LookAt:=xlPart, LookIn:=xlValues)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            'detalle
            If sh2.Cells(b.Row, "B").Value = "" Then
                sh2.Cells(b.Row, "B").Value = b.Value
            End If
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If
    MsgBox "End"
    
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,520
Messages
6,114,099
Members
448,548
Latest member
harryls

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