Remove rows with duplicate email addresses

I use Excel 2013 and need code to remove rows containing duplicate email addresses.  If a duplicate email address is found, it should remove the row containing it, but starting with the row that contains the least amount of other information adjacent to the address.

Assistance is greatly appreciated.
frugalmuleAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ramesh VCommented:
You want the entire row to be removed?
0
frugalmuleAuthor Commented:
Yes, beginning with the row that contains the least amount of additional information
0
Martin LissOlder than dirtCommented:
Before you test this make a copy of your sheet and then run the DeleteDupes macro. It assumes that the emails are in column A and that column Z is unused. If either of those assumptions are false then change one or both of the values in lines 13 and 14. Note line 56. If there is no heading then change the 2 in line 57 to 1.

Sub DeleteDupes()

Dim lngIndex As Long
Dim SearchRange As Range
Dim FindWhat As Variant
Dim FoundCells As Range
Dim FoundCell As Range
Dim cel As Range
Dim intBlankCount As Integer
Dim intLeastBlanks As Integer
Dim lngRow As Long
Dim lngLastCol As Long
Const EMAIL_COL = "A" ' Assumes email addresses are in column "A"
Const KEEP_FLAG_COL = "Z" ' The flag column

Set SearchRange = Range(EMAIL_COL & ":" & EMAIL_COL)

lngLastCol = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column

Application.ScreenUpdating = False

' Find duplicates in the range
For Each cel In SearchRange
    If cel.Value <> "" Then
        FindWhat = cel.Value

        Set FoundCells = FindAll(SearchRange:=SearchRange, _
                                FindWhat:=FindWhat, _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                MatchCase:=False, _
                                BeginsWith:=vbNullString, _
                                EndsWith:=vbNullString, _
                                BeginEndCompare:=vbTextCompare)
        If FoundCells.Count > 1 Then
            ' We've found a set of duplicates
            intLeastBlanks = 9999
            lngRow = 0
            ' In the set, find the row withy the least blanks (in other word the most information)
            For Each FoundCell In FoundCells
                intBlankCount = Application.WorksheetFunction.CountBlank(Range(EMAIL_COL & FoundCell.Row & lngLastCol & FoundCell.Row))
                If intBlankCount < intLeastBlanks Then
                    lngRow = FoundCell.Row
                    intLeastBlanks = intBlankCount
                End If
            Next FoundCell
            ' Mark the row in the set that we want to keep
            Cells(lngRow, KEEP_FLAG_COL).Value = "Keep"
        Else
            Cells(cel.Row, KEEP_FLAG_COL).Value = "Keep"
        End If
    End If
Next

' Delete the rows that aren't flagged. Assumes a heading in row 1.
For lngRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row To 2 Step -1
    If Cells(lngRow, KEEP_FLAG_COL) <> "Keep" Then
        Cells(lngRow, KEEP_FLAG_COL).EntireRow.Delete
    End If
Next

' Clear the flag column
Columns(KEEP_FLAG_COL & ":" & KEEP_FLAG_COL).Select
Selection.ClearContents

Application.ScreenUpdating = True

End Sub
Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
               Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range

' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Code is from http://www.cpearson.com/excel/FindAll.aspx

Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean


CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
    XLookAt = xlPart
Else
    XLookAt = LookAt
End If

' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.

For Each Area In SearchRange.Areas
    With Area
        If .Cells(.Cells.Count).Row > MaxRow Then
            MaxRow = .Cells(.Cells.Count).Row
        End If
        If .Cells(.Cells.Count).Column > MaxCol Then
            MaxCol = .Cells(.Cells.Count).Column
        End If
    End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)

On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
        after:=LastCell, _
        LookIn:=LookIn, _
        LookAt:=XLookAt, _
        SearchOrder:=SearchOrder, _
        MatchCase:=MatchCase)

If Not FoundCell Is Nothing Then
    Set FirstFound = FoundCell
    Do Until False ' Loop forever. We'll "Exit Do" when necessary.
        Include = False
        If BeginsWith = vbNullString And EndsWith = vbNullString Then
            Include = True
        Else
            If BeginsWith <> vbNullString Then
                If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
            If EndsWith <> vbNullString Then
                If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
        End If
        If Include = True Then
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
        End If
        Set FoundCell = SearchRange.FindNext(after:=FoundCell)
        If (FoundCell Is Nothing) Then
            Exit Do
        End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
        End If

    Loop
End If
    
Set FindAll = ResultRange

End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Martin LissOlder than dirtCommented:
I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2015
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.