Finding and leaving only duplicates in spreadsheet - excel

Question

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)
Else
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
Next
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.

Answer 1

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

Answer 2

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
Else
Set rngToDelete = Union(rngToDelete, c)
End If
End If
Next
If Not rngToDelete Is Nothing Then rngToDelete.Delete Shift:=xlUp
End Sub