Forum Discussion

Copper Contributor

Jul 15, 2021

Solved

Excel fails to remove dupllicates in simple file

I'm using the Remove Duplicates function on simple data sets (usually 20-40 items). Excel fails to remove duplicates, and the feedback received in 'completed' dialogs doesn't seem to be consistent or...

Excel not removing duplicates in simple example.mp424.9 MB

Jul 16, 2021

Run this macro. Please test on a copy of your data first.

Sub RemoveDups()
    Dim rng As Range
    Dim r As Long
    Dim m As Long
    Dim c As Long
    Application.ScreenUpdating = False
    m = Range("A:D").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rng = Range("A2:D" & m)
    For c = 4 To 1 Step -1
        m = Cells(Rows.Count, c).End(xlUp).Row
        For r = m To 2 Step -1
            If Application.CountIf(rng, Cells(r, c).Value) > 1 Then
                Cells(r, c).Delete Shift:=xlShiftUp
            End If
        Next r
    Next c
    Application.ScreenUpdating = True
End Sub

Brett745

Copper Contributor

Jul 16, 2021

So many options!
With my small data sets I could be happy with any of those, but let's aim at "delete them and move the cells upwards"
For my needs, each column is a list of related items being 'picked' for orders, and we only need to pull a whole box of each unique item to later fill specific orders with. Stated differently, there is no relationship between the cell contents of any particular row, and it's not a database record such as name/address/item that we wouldn't want to scramble.

HansVogelaar

MVP

Jul 16, 2021

Brett745

Run this macro. Please test on a copy of your data first.

Sub RemoveDups()
    Dim rng As Range
    Dim r As Long
    Dim m As Long
    Dim c As Long
    Application.ScreenUpdating = False
    m = Range("A:D").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rng = Range("A2:D" & m)
    For c = 4 To 1 Step -1
        m = Cells(Rows.Count, c).End(xlUp).Row
        For r = m To 2 Step -1
            If Application.CountIf(rng, Cells(r, c).Value) > 1 Then
                Cells(r, c).Delete Shift:=xlShiftUp
            End If
        Next r
    Next c
    Application.ScreenUpdating = True
End Sub

Brett745
Copper Contributor
Jul 16, 2021
Macro works well. I"ll have to learn how to expand it to more columns, but I think the Set rng and c will get me there.
THANK. YOU for your willingness to help me out -- it is appreciated.