How to Delete all emails in adjacent cells that come from the same domain. I only want to keep 1st record from a given domain

[jodphd]

I am using Excel 2016. I have a spreadsheet with a column of email addresses where some adjacent cells are from other people at a company and I only want to keep the first email address from each domain and delete any subsequent email addresses from the same domain. Not all adjacent records will have the same domain--some could be from a new domain that I want to keep.

Example: here is original column view:

test@yahoo.com

john@doe.com

richard@doe.com

joe@msn.com

test@hotmail.com

january@hotmail.com

ron@arizona.net

Here is what I want corrected column to look like:

test@yahoo.com

john@doe.com

joe@msn.com

test@hotmail.com

ron@arizona.net

Book1
	A	B
1	Original Data	Corrected Data
2	test@yahoo.com	test@yahoo.com
3	john@doe.com	john@doe.com
4	richard@doe.com	joe@msn.com
5	joe@msn.com	test@hotmail.com
6	test@hotmail.com	ron@arizona.net
7	january@hotmail.com
8	ron@arizona.net
9
10
11
12
13
Sheet1

The spreadsheet will only have 1 column in it---just email addresses. There will be a lot of records so I ma looking for a way to automate this. Thanks in advance.

 

[tonyyy]

You might consider the following...

Sub UniqueDomains()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim r As Range
Dim LastRow As Long, i As Long
Dim arr() As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws1 = ActiveSheet
ws1.Copy after:=ws1
Set ws2 = ActiveSheet

LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For Each r In ws2.Range("A2:A" & LastRow)
    arr = Split(r, "@")
    r.Offset(0, 1) = arr(0)
    r.Offset(0, 2) = arr(1)
Next r

'ws2.Range("A2:C" & LastRow).Sort key1:=Range("C2")
For i = LastRow To 2 Step -1
    If ws2.Cells(i, 3) = ws2.Cells(i + 1, 3) Then ws2.Rows(i + 1).EntireRow.Delete
    ws2.Cells(i, 2) = ws2.Cells(i, 2) & "@" & ws2.Cells(i, 3)
Next i
ws2.Range("A2:A" & LastRow).Copy Destination:=ws1.Range("B2")
ws2.Delete
ws1.Activate
Columns(2).AutoFit

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Cheers,

Tony

 

[DanteAmor]

Hi and welcome to MrExcel!

Here is another macro for you to consider.
The results in column B

Sub Delete_emails()
  Dim dic As Object, a As Variant, i As Long, domain As String
  a = Range("A2", Range("A" & Rows.Count).End(3)).Value
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    domain = Split(a(i, 1), "@")(1)
    If Not dic.exists(domain) Then dic(domain) = a(i, 1)
  Next
  Range("B2").Resize(dic.Count).Value = Application.Transpose(dic.items)
End Sub

---
HOW TO INSTALL MACROs
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (Delete_emails) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "Yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

 

[jtakw]

Hi,

Formula option, Filter or Delete blank rows as you like:

Book3.xlsx
	A	B
1	Original Data	Corrected Data
2	test@yahoo.com	test@yahoo.com
3	john@doe.com	john@doe.com
4	richard@doe.com
5	joe@msn.com	joe@msn.com
6	test@hotmail.com	test@hotmail.com
7	january@hotmail.com
8	ron@arizona.net	ron@arizona.net
Sheet1045

Cell Formulas
Range	Formula
B2:B8	B2	=IF(SUMPRODUCT(--ISNUMBER(SEARCH("*"&MID(A2,FIND("@",A2),99),A$2:A2)))=1,A2,"")

 

[Peter_SSs]

Another macro approach

Sub OnePerDomain()
  With Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
    .Formula = "=vlookup(replace(A2,1,find(""@"",A2)-1,""*"")," & .Offset(, -1).Address & ",1,0)"
    .Value = .Value
    .RemoveDuplicates Columns:=1, Header:=xlNo
  End With
End Sub

.. and another formula approach

jodphd.xlsm
	A	B
1	Original Data	Corrected Data
2	test@yahoo.com	test@yahoo.com
3	john@doe.com	john@doe.com
4	richard@doe.com	joe@msn.com
5	joe@msn.com	test@hotmail.com
6	test@hotmail.com	ron@arizona.net
7	january@hotmail.com
8	ron@arizona.net
Formula

Cell Formulas
Range	Formula
B2:B8	B2	=IFNA(INDEX($A$2:$A$100,MATCH(0,INDEX(COUNTIF($B$1:B1,REPLACE($A$2:$A$100,1,FIND("@",A$2:A$100)-1,"*"))+(A$2:A$100=""),0),0)),"")