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

You've *Select*ed a range based on Selection,Selection.Offset(0,3) and then you're doing `Set rng = Range(Selection, Selection.End(xlDown))`. Within a table, usually `End(xlDown)` will include all rows until the last row in the table. Also worth noting, try to avoid using `Select` :) https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba — David Zemens, Nov 02 '21 at 14:46
I know i shouldnt be using select but it was the easiest way i know. Im still a little new to VBA. But i do want it to go to the very last row in the table because the most recent project and all its contacts will get added to the bottom of the table always. My issue is its removing duplicates from the whole table and not just the current selection. — Gray Ciancia, Nov 02 '21 at 14:52
This is interesting, it seems your code works fine if the data is not part of a table. I was only able to reproduce your issue when I used a table. — Professor Pantsless, Nov 02 '21 at 15:27

Warcupine · Accepted Answer · 2021-11-03T12:51:09.273

1

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
        if not delrng is nothing then
            delrng.Delete
        end if
    End With
                    
End Sub

edited Nov 03 '21 at 12:51

answered Nov 02 '21 at 14:53

Warcupine

4,460
3
15
24

I have discovered upon trying to use this that Microsoft Scripting Runtime is not available on mac! There seems to be a workaround found here https://sysmod.wordpress.com/2011/11/02/dictionary-class-in-vba-instead-of-scripting-dictionary/. So im going to try it out with this. – Gray Ciancia Nov 02 '21 at 15:22
So this goes through all rows in the table to find ones with project names, then adds all contacts to that projects dictionary and deletes any duplicates at the end? – Gray Ciancia Nov 02 '21 at 19:14
@GrayCiancia Yes, it creates a dictionary with the key being `ProjectContact` if it finds a duplicate then it stores the row in a range and at the end deletes them all. It does it at the end to be faster and so we don't need to modify the `i` during a loop. – Warcupine Nov 02 '21 at 19:43
Okay, running through the code line by line everything seems to run how it's supposed to until it reaches `delrng.Delete`, I'm getting the error code "method Delete of object Range failed." – Gray Ciancia Nov 02 '21 at 20:54
1

@Gray Ciancia: I have tested the code and it basically works fine. When there are no duplicates, this error will occur. You can fix it simply by using the line `If not delrng Is Nothing Then delrng.Delete` instead of the line `delrng.Delete`. Also, the code is written to find duplicates in the second column. To make it work for the fourth column, you will have to replace the three occurrences of `.Cells(i, 2)` with `.Cells(i, 4)`. – VBasic2008 Nov 03 '21 at 03:51
Whoops, my bad fixed now. – Warcupine Nov 03 '21 at 12:59
1

I already modified it to fit my sheet, the issue seems to arise when trying to delete entire rows from multiple selections in the table at once. I moved `delrng.Delete` to inside the if statement in place of the part that adds multiple rows to `delrng` so it deletes duplicates individually as they are found. May take a little longer to run through but it works, and ill never have more than 10 duplicates at a time so it shouldn't be an issue. Thank you! – Gray Ciancia Nov 03 '21 at 16:33

VBasic2008 · Answer 2 · 2021-11-02T16:41:30.537

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

score 0 · Answer 3 · answered Nov 02 '21 at 17:39

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

Remove Duplicates From Current Selection in a Table

3 Answers3

Remove Duplicates in Consecutive Ranges Using RemoveDuplicates

Remove Duplicates in Consecutive Ranges Using `RemoveDuplicates`