Im trying to remove duplicate contacts from a range in my table, but any time it runs it removes duplicates from the whole table, not just the current selection.

This isnt something i want since the same contact is able to be under different projects in the table. I just dont want duplicates of that contact under the same project.

Here is a sample of what i mean but in reality theres a lot more contacts and projects. It should only remove the duplicate Contact 9 from the last project input. So Contact 1 and Contact 2 shouldnt be removed but with how its written now, they are.

Here is my code

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

Im not quite sure what im doing wrong and ive gone through the documentation and havent been able to figure it out.

Any help would be appreciated!

CodePudding user response：

This will delete all duplicate rows within a project using a dictionary. It is not reliant upon selecting a range, it just runs through all the projects.

I'm assuming your data starts at Column A and Column B is the longest Column.

Sub removeDupes()
    Dim i As Long
    Dim lr As Long
    
    Dim dict As Object
    Dim project As String
    
    Dim delrng As Range
    Set dict = CreateObject("Scripting.Dictionary") 'Reference is Microsoft Scripting Runtime if you want early binding
    
    With Sheets("Sheet1") 'Change as needed
        lr = .Cells(.Rows.Count, 2).End(xlUp).Row
        
        For i = 2 To lr
            If .Cells(i, 1).Value <> "" Then
                project = .Cells(i, 1).Value
            End If
            
            If Not dict.exists(project & .Cells(i, 2).Value) Then
                dict.Add project & .Cells(i, 2).Value, ""
            Else
                If delrng Is Nothing Then
                    Set delrng = .Rows(i).EntireRow
                Else
                    Set delrng = Union(delrng, .Rows(i).EntireRow)
                End If
            End If
        Next i
        
        delrng.Delete
    End With
                    
End Sub

CodePudding user response：

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

CodePudding user response：

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