Removing Duplicates Based on Other Cell Value

Question

forgive me if this is a thick question:

I have a table of training completions e.g.

User	Training Course	Status
1	Course 1	Complete
1	Course 1	Complete
1	Course 1	Incomplete
1	Course 2	Complete
1	Course 3	Incomplete

My source data includes many duplications. What I want to be left with is one status per training course. If there is both a 'complete' and 'incomplete' for the same course, I would like to remove any instance of 'incomplete' e.g.

User	Training Course	Status
1	Course 1	Complete
1	Course 2	Complete
1	Course 3	Incomplete

Hope I've explained that well enough. I'd be most grateful of any suggestions.

I've tried various formulae I've found online, plus an onerous workfow of removing duplicates and filtering.

Maybe a combination of UNIQUE function on the first 2 columns and then a COUNTIFS to detect if a Complete is present..? — CLR, Jul 07 '23 at 15:40
I think so, something like this, maybe. There are more complicated but robust ways to do it, but if this only has to be done once or infrequently, I think a lookup to a number, combined with MINIFS and UNIQUE and then a final lookup back to the text value. That can be extended if he has more statuses than what he's given: https://docs.google.com/spreadsheets/d/1oyHPHffF8kcbwvZp_4X3fRGwXthL5ww3m5_N2s2Snw4/edit#gid=0 — Chris Strickland, Jul 07 '23 at 17:47

score 1 · Answer 1 · answered Jul 07 '23 at 19:21

Remove Duplicates With a Twist

Sub RemoveDupes()

    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim rg As Range, rCount As Long
    
    With ws.Range("A1").CurrentRegion
        rCount = .Rows.Count - 1
        If rCount = 0 Then Exit Sub
        Set rg = .Resize(rCount).Offset(1)
    End With
    
    Dim Data(): Data = rg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim urg As Range, rrg As Range, r As Long
    Dim rStr As String, nStr As String, oStr As String
    
    For r = 1 To rCount
        rStr = CStr(Data(r, 1)) & "@" & CStr(Data(r, 2))
        If dict.Exists(rStr) Then
            oStr = CStr(Data(dict(rStr), 3))
            nStr = CStr(Data(r, 3))
            If StrComp(oStr, "Complete", vbTextCompare) <> 0 Then
                If StrComp(nStr, "Complete", vbTextCompare) = 0 Then
                    Set rrg = rg.Rows(dict(rStr))
                    dict(rStr) = r
                End If
            End If
            If rrg Is Nothing Then
                Set rrg = rg.Rows(r)
            End If
        Else
            dict(rStr) = r
        End If
        If Not rrg Is Nothing Then
            If urg Is Nothing Then
                Set urg = rrg
            Else
                Set urg = Union(urg, rrg)
            End If
            Set rrg = Nothing
        End If
    Next r
        
    If urg Is Nothing Then
        MsgBox "No duplicates found.", vbExclamation
    Else
        urg.Select ' when done testing, use the following line instead
        'urg.Delete xlShiftUp
        MsgBox "Duplicates removed.", vbInformation
    End If
        
End Sub

Kavorka · Accepted Answer · 2023-07-07T15:53:30.293

Assuming your data starts in Cell A1, you will want to sort the data to ensure that is there is a complete and Incomplete status that the complete is before the incomplete. then you can remove duplicates based on the User and Training Course you can use the below code to remove duplicates. Please keep in mind you will need to change the Sheet1 to the name of your sheet

Option Explicit

Sub SortandRemove()

    Dim oWB As Workbook: Set oWB = ThisWorkbook
    Dim oWS As Worksheet: Set oWS = oWB.Sheets("Sheet1")
    
    With oWS
        With .Sort
            With .SortFields
                .Clear
                .Add2 Key:=oWS.Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add2 Key:=oWS.Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add2 Key:=oWS.Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With
        
            .SetRange oWS.Range("A1").CurrentRegion
            .Header = xlYes
            .MatchCase = False
            .Apply
        End With
    
        .Range("$A$1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    End With
End Sub

If this has solved your issue, please select the checkmark to let others know — Kavorka, Jul 11 '23 at 11:51

Removing Duplicates Based on Other Cell Value

2 Answers2

Remove Duplicates With a Twist