Home » excel » excel – Finding and leaving only duplicates in spreadsheet

excel – Finding and leaving only duplicates in spreadsheet

Posted by: admin May 14, 2020 Leave a comment


In Excel, I created a macro to find and leave only duplicated values across multiple columns within the current selection–removing any cells that were only found once. Well, at least that’s what I thought I created anyway, but it doesn’t seem to work. Here’s what I’ve got:

Sub FindDupsRemoveUniq()
    Dim c As Range
    Dim counted() As String
    For Each c In selection.Cells
        Dim already_found As Boolean
        already_found = Contains(counted, c.Text)
        If Not (already_found) And WorksheetFunction.CountIf(selection, c) <= 1 Then
            c.Delete Shift:=xlUp
        ElseIf ("" <> c.Text) And Not (already_found) Then
            If Len(Join(counted)) = 0 Then
                ReDim counted(1)
                ReDim Preserve counted(UBound(counted) + 1)
            End If
            counted(UBound(counted) - 1) = c.Text
        End If
    Next c
End Sub

Private Function Contains(ByRef arr() As String, cell As String) As Boolean
    Dim i As Integer
    Contains = False
    If Len(Join(arr)) = 0 Then
        Exit Function
    End If
    For i = LBound(arr) To UBound(arr)
        If cell = arr(i) Then
            Contains = True
            Exit Function
        End If
End Function

I had to do this because I had ~180k items across multiple columns, and I had to find anything that was duplicated, and under which column those duplicates are showing in. However, when it completes, it seems that most of the singular instances are still there. I can’t figure out why this isn’t working.

EDIT: This is what my code ended up looking like based on @brettdj’s solution below:

Sub FindDupsRemoveUniq()
    Dim lRow As Long
    Dim lCol As Long
    Dim total_cells As Long
    Dim counter As Long
    Dim progress_str As String
    Dim sel
    sel = selection.Value2
    total_cells = WorksheetFunction.Count(selection)
    counter = 0
    progress_str = "Progress: "
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.StatusBar = progress_str & "0 of " & total_cells & " : 0% done"
    For lRow = 1 To UBound(sel, 1)
        For lCol = 1 To UBound(sel, 2)
            counter = counter + 1
            Application.StatusBar = progress_str & counter & " of " & total_cells & " : " & Format(counter / total_cells, "0%")
            If WorksheetFunction.CountIf(selection, sel(lRow, lCol)) < 2 Then
                sel(lRow, lCol) = vbNullString
            End If
        Next lCol
    Next lRow
    selection = sel
    Application.StatusBar = "Deleting blanks..."
    selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    Application.StatusBar = "Done"
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

I tried to speed things up with a few optimizations, though I’m not sure how much they helped. Also, the status bar updates ended up being rather pointless too since Excel got so bogged down. It seemed to give up updating after ~300 iterations. Nonetheless, it did work.

How to&Answers:

I would suggest using an array, same approach otherwise as simoco

This approach removes the cell contents but doesn’t shift the cells up as I wasn’t clear that you wanted this

Sub Kill_Unique()
Dim X
Dim lngRow As Long
Dim lngCol As Long
X = Selection.Value2
For lngRow = 1 To UBound(X, 1)
    For lngCol = 1 To UBound(X, 2)
        If Application.CountIf(Selection, X(lngRow, lngCol)) < 2 Then X(lngRow, lngCol) = vbNullString
    Next lngCol
Next lngRow
Selection.Value2 = X
End Sub


If you want delete all cells with unique values from selection, try this one:

Sub test()
    Dim rngToDelete As Range, c As Range

    For Each c In Selection
        If WorksheetFunction.CountIf(Selection, c) = 1 Then
            If rngToDelete Is Nothing Then
                Set rngToDelete = c
                Set rngToDelete = Union(rngToDelete, c)
            End If
        End If

    If Not rngToDelete Is Nothing Then rngToDelete.Delete Shift:=xlUp
End Sub