Remove Duplicates From Current Selection in a Table

Question

I'm trying to remove duplicate contacts from a range in my table.

Instead duplicates are removed from the whole table, not just the current selection.

The same contact is able to be under different projects in the table. I just don't want duplicates of that contact under the same project.

Here is a sample of what I mean. In reality there are a lot more contacts and projects.

It should only remove the duplicate Contact 9 from the last project input. Contact 1 and Contact 2 shouldn't be removed.

Dim rng As Range

'Rowies is defined elsewhere as the top row of the last entered project, in this sample it would be A8
Rowies.Select

Range(Selection, Selection.Offset(0, 3)).Select

Set rng = Range(Selection, Selection.End(xlDown))

'i have duplicates removed based upon their email addresses.
rng.RemoveDuplicates Columns:=4, Header:=xlNo

Answer 1

Remove Duplicates in Consecutive Ranges Using RemoveDuplicates

• It is assumed that the (table) range is contiguous (no empty rows or columns) and it starts in A1 and has one row of headers.
• It is assumed that each project starts with an entry in the Project column.
• Only the Dupe column is used to qualify a row as a duplicate.
• Only rows (not entire rows) of the range are deleted not affecting the cells to the right.
• Due to the need of deleting empty rows, the processing is done backward, from bottom to top. Each project range is first checked if it has more than one row. If so, any duplicates are removed. If there was any removing (clearing of project range rows), at least the last cell in the dupe column becomes empty. This information is then used to delete the appearing empty project range rows.

Option Explicit

Sub RemoveProjectDuplicates()
    
    Const wsName As String = "Sheet1"
    Const pCol As Long = 1 ' Project Column
    Const dCol As Long = 4 ' Dupe Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' Table Range
    Dim fRow As Long: fRow = rg.Row + 1 ' First Data Row
    Dim plRow As Long: plRow = rg.Rows.Count ' Project Last Row
    
    Dim prg As Range ' Project Range
    Dim pdrg As Range ' Project Delete Range
    Dim plCell As Range ' Project Last Cell
    Dim dlCell As Range ' Dupe Last Cell
    Dim pfRow As Long ' Project First Row
    Dim pdfRow As Long ' Project Delete First Row
    
    Application.ScreenUpdating = False
    
    ' Loop backwards.
    Do
        Set plCell = ws.Cells(plRow, pCol)
        If IsEmpty(plCell) Then ' project has more than one row
            ' Remove duplicates.
            pfRow = plCell.End(xlUp).Row
            Set prg = rg.Rows(pfRow).Resize(plRow - pfRow + 1)
            prg.RemoveDuplicates dCol, xlNo
            ' Delete (trailing) empty project rows.
            Set dlCell = plCell.EntireRow.Columns(dCol)
            If IsEmpty(dlCell) Then ' duplicates found and removed
                pdfRow = dlCell.End(xlUp).Row + 1
                Set pdrg = prg.Resize(plRow - pdfRow + 1).Offset(pdfRow - pfRow)
                pdrg.Delete xlShiftUp
            'Else ' no duplicates found, no need to delete
            End If
        Else ' project has one row only
            pfRow = plRow
        End If
        plRow = pfRow - 1
    Loop Until pfRow = fRow
    
    Application.ScreenUpdating = True
    
End Sub

Answer 2

Using a Collection object rather than a Dictionary. Step 1 highlights the duplicates , Step 2 deletes the highlighted items. (not tested on Mac)

Option Explicit

Sub RemoveDups()

    Const COL_DUPL = "Email"
    Const COL_PROJECT = "Project Name"

    Dim tbl As ListObject, r As Long, lastrow As Long
    Dim c1 As Long, c2 As Long, i As Long, n As Long
    Dim col As Collection

    ' table
    Set tbl = ActiveSheet.ListObjects("Table1")
    With tbl
        c1 = .ListColumns(COL_PROJECT).Index
        c2 = .ListColumns(COL_DUPL).Index
    End With
    
    With tbl.DataBodyRange
         ' step 1 mark duplicates
        lastrow = .Rows.Count
        For r = 1 To lastrow
            If .Cells(r, c1) = "" Then
                ' mark
                If IsDup(col, .Cells(r, c2)) Then
                    .Cells(r, c2).Interior.Color = vbYellow
                    n = n + 1
                Else
                    .Cells(r, c2).Interior.Pattern = xlNone
                End If
            Else
               Set col = New Collection
               col.Add Trim(.Cells(r, c2))
            End If
        Next
     
        ' step 2 delete
        If n > 0 Then
            If MsgBox("Delete " & n & " duplicates ?", vbYesNo) = vbYes Then
               For r = lastrow To 1 Step -1
                   If .Cells(r, c2).Interior.Color = vbYellow Then
                       .Rows(r).Delete
                   End If
               Next
            End If
            MsgBox "Done", vbInformation
        Else
            MsgBox "No duplicates", vbInformation
        End If
     End With
     
End Sub

Function IsDup(ByRef col As Collection, item As String) As Boolean
    Dim i As Long, v As Variant
    IsDup = False
    item = Trim(item)
    For Each v In col
        If item = v Then
            IsDup = True
            Exit For
        End If
    Next
    If Not IsDup Then col.Add item
End Function