Excel 2010 already has the great new feature of being able to remove duplicates from a range of cells with the click of a button, but what if you want to keep the duplicates and remove the unique items? I got a question at work today about this, so I hacked this subroutine together.

vbaKeepDuplicates

Public Sub KeepDuplicates()

    'Create one array for our raw data and one array for our duplicates
    Dim varDataArr() As Variant, varDupesArr() As Variant
    'Create some counters for our loops
    Dim i As Long, j As Long, k As Long, count As Long
    'Create a Boolean variable to tell us if we find a matching value
    Dim bolMatch As Boolean
    
    'Load the selection into our raw data array, varDataArr
    With ActiveSheet
        varDataArr = Range(.Cells(ActiveCell.Row, ActiveCell.Column), .Cells(Selection.Rows.count + 1, ActiveCell.Column))
        'We clear the original data selection so we have room to report our duplicates
        Range(.Cells(ActiveCell.Row, ActiveCell.Column), .Cells(Selection.Rows.count + 1, ActiveCell.Column)).ClearContents
    End With
    
    'Looping through the list, counting the number of times any given number shows up
    ' keeps the number if it shows up more than once
    k = 0
    For i = LBound(varDataArr, 1) To UBound(varDataArr, 1)
        bolMatch = False
        count = 0
        For j = LBound(varDataArr) To UBound(varDataArr, 1)
            If varDataArr(i, 1) = varDataArr(j, 1) Then
                count = count + 1
                If count > 1 Then
                    bolMatch = True
                    ReDim Preserve varDupesArr(k)
                    varDupesArr(k) = varDataArr(i, 1)
                    k = k + 1
                    Exit For
                End If
            End If
        Next j
    Next i
    
    'Output our new, dupes only range to the worksheet
    With ActiveSheet
        Range(.Cells(ActiveCell.Row, ActiveCell.Column), .Cells(ActiveCell.Row + UBound(varDupesArr), ActiveCell.Column)).Value = Application.Transpose(varDupesArr)
        '****Uncomment the below if you want a list of all the unique numbers that had duplicates in the original list
        'Range(.Cells(ActiveCell.Row, ActiveCell.Column), .Cells(ActiveCell.Row + UBound(varDupesArr), ActiveCell.Column)).RemoveDuplicates Columns:=1, Header:=xlGuess
    End With
    
End Sub