Deleting Rows Based on Duplicate Entries

[NamssoB]

Here's something I need help with. I need to delete entire rows based on duplicate entries in specific cells. Here are the details:

I have a list of "membership records" in the following format (generated from a database report):

MemberID First Last Age Group
02100319-01 Mildred Lopez Adult
02101485-01 Shelton Hawkins Adult
02103489-01 John Rivera Adult
02103489-02 Traci Rivera Adult
02106796-01 Jordan Chanski Adult
02106796-02 Gabrielle Chanski Adult
02109301-01 Shavon Lofton Adult
02109301-02 Charles Holder Adult
02109638-01 Kendra Amaya Adult
02109638-02 Kevin Amaya Adult
02109638-03 Kassie Amaya Adult

(Note that Left(MemberID,8) is what I'm looking at. The Right x2 character could be anything)

I need to delete/keep rows based on the following rules:
1) If (Left(MemberID,8) is unique (there is only one), DELETE ROW
2) If there are TWO identical Left(MemberID,8), DELETE BOTH ROWS
3) 3 or more, keep all of them

Basically, this is a giant database report of memberships, and a maximum of TWO people can be on a membership. So if I find ONE or TWO, I want them removed from the report (they are valid). When the code is finished processing, all the should be left are those that have 3 or more (there could be any number of people listed under one membership, so technically there is no maximum).

In the data above, only the last three rows shown should remain (three identical Left(MemberID,8) entries).

BONUS points if you can figure out how to insert a "separator" row between the groups of MemberID's that remain, or even better, alternate the background color of each unique Left(MemberID,8) group. For example:

02109638-01 Kendra Amaya Adult
02109638-02 Kevin Amaya Adult
02109638-03 Kassie Amaya Adult
---------------------------------------------------
02109638-01 Kendra Amaya Adult
02109638-02 Kevin Amaya Adult
02109638-03 Kassie Amaya Adult
---------------------------------------------------
02109638-01 Kendra Amaya Adult
02109638-02 Kevin Amaya Adult
02109638-03 Kassie Amaya Adult

FYI, I started with the following code, but then realized Iw as way over my head.

    Do While Roffset < lastrow
        If Left(ActiveCell.Offset(Roffset, 0).Value, 8) = Left(ActiveCell.Offset(Roffset + 1, 0).Value, 8) Then
            If Left(ActiveCell.Offset(Roffset + 1, 0).Value, 8) = Left(ActiveCell.Offset(Roffset + 2, 0).Value, 8) Then
                ' KEEPER
            Else
                ActiveCell.Offset(Roffset, 0).EntireRow.Delete
                ActiveCell.Offset(Roffset + 1, 0).EntireRow.Delete
            End If
        Else
            ActiveCell.Offset(Roffset, 0).EntireRow.Delete
        End If
        Roffset = Roffset + 1
    Loop

 

[Anand Sharma]

Try this

=COUNTIF($A$1:$B$3,LEFT(A1,8)) use this formula and then paste special in your data and then choose value

after than run below code


Sub deletedup()

For j = 1 To 11


For i = 1 To 1

If Range("E" & i) < 3 Then
Rows(i).Delete
End If

Next i
Next j


End Sub

change the reference cell according to the cell where data has been pasted as value

Hope this would work for you

 

[NamssoB]

Anand, thanks for the reply but I'm not sure I understand what you're asking me to do. I don't want to have to manipulate the actual spreadsheet prior to running any code. My end goal is to just click on a button to process the worksheet.

At this point I need help with thinking through the logic of what I need to do, then the most efficient VBA code to accomplish it.

 

[NamssoB]

OK, I have it working. But it feels VERY inefficient. Anyone have ideas:

    ' Goto top to start looking for duplicate member ID entries.  1 gets deleted, 2 get deleted, 3 or more are kept
    Range("A1").Select
    Dim Roffset As Long
    Dim Rincrement As Long
    Dim bNewNumFound As Boolean
    
    Roffset = 1
    Rincrement = 0
    
    Do
        If Left(ActiveCell.Offset(Roffset, 0).Value, 8) <> Left(ActiveCell.Offset(Roffset + 1, 0).Value, 8) Then
            ' Get here if SINGLE unit
            ActiveCell.Offset(Roffset, 0).EntireRow.Delete
        Else
            If Left(ActiveCell.Offset(Roffset, 0).Value, 8) <> Left(ActiveCell.Offset(Roffset + 2, 0).Value, 8) Then
                ' Get here if DOUBLE unit
                ActiveCell.Offset(Roffset, 0).EntireRow.Delete
                ActiveCell.Offset(Roffset, 0).EntireRow.Delete
            Else
                ' Get here if 3+ matching MemberIDs (Need to keep them)
                ' Need to keep comparing until we get to a new MemberID
                Rincrement = 2
                bNewNumFound = False
                Do
                    If Left(ActiveCell.Offset(Roffset, 0).Value, 8) <> Left(ActiveCell.Offset(Roffset + Rincrement, 0).Value, 8) Then
                        bNewNumFound = True
                        Roffset = Roffset + Rincrement
                    Else
                        Rincrement = Rincrement + 1
                    End If
                Loop Until bNewNumFound
                
            End If
        End If
        ' Reset lastrow
        With ActiveSheet
            lastrow = .UsedRange.Rows.Count + .UsedRange.Row - 1
        End With
        
        ' Status bar updates

    Loop While Roffset < lastrow