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.
I would suggest using an array, same approach otherwise as
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 Else Set rngToDelete = Union(rngToDelete, c) End If End If Next If Not rngToDelete Is Nothing Then rngToDelete.Delete Shift:=xlUp End Sub