Thread: Remove unique rows and keep duplicates

This solution is for Excel versions earlier than 2007.
First, I would do a conditional format on all duplicates. Use the formula found in this link on Column B.

http://office.microsoft.com/en-au/ex...001136616.aspx

then create a UDF as shown here

http://www.datapigtechnologies.com/f...rtonColor.html

Once you have sorted the file by color, you can then delete the appropriate rows very quickly.

For 2007 users, use conditional format wizard, sort and delete.

Alan

Hello Terry,
I wrote a function to move duplicates to another sheet.
Take a look, maybe it will suit your needs.

Gordon in Rovereto Italy

Option Explicit

Function MoveALL_Dupes(ByVal whatColumn As Long) As Boolean
' Uses a counting formula together with the autofilter
' to find and Move ALL duplicates from the Activesheet
' to new worksheet.
'
' This is not the opposite of unique
'
' In some cases it's desirable to remove ALL duplicates
' not just the 2nd occurence.
' because human intervention Is required to fix the problem.
' How can a computer know if the 1st or 2nd is the correct one.
' it's a 50/50 random chance that the 1st occurence is correct
'

Dim wksTemp As Worksheet
Dim wkshtDupes As Worksheet
Dim rng2Check As Range
Dim rngTop As Range
Dim rngBottom As Range
Dim rngCountFormula As Range
Dim iLastRow As Long
Dim shtNbr As Long

    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ActiveSheet.Select
    Set wksTemp = ActiveSheet
    
    iLastRow = wksTemp.Cells(65536, whatColumn).End(xlUp).Row
    
    Columns(whatColumn + 1).Insert Shift:=xlToRight
    Cells(1, whatColumn + 1).Value = "Duplicate List"
    
    'Set the range to separate duplicates from unique
    Set rngTop = Cells(2, whatColumn)
    Set rngBottom = Cells(iLastRow, whatColumn)
    Set rng2Check = wksTemp.Range(rngTop, rngBottom)
    Set rngCountFormula = wksTemp.Range(rngTop.Offset(0, 1), rngBottom.Offset(0, 1))
    
    'Add a workbook name for it so we can use it in the formula
    ActiveWorkbook.Names.Add Name:="rngCheck", _
        RefersTo:=rng2Check, Visible:=True
        
    'Insert formula to count duplicate account numbers
    rngCountFormula.FormulaR1C1 = "=COUNTIF(rngCheck,""=""&RC[-1])"
    rngCountFormula.Value = rngCountFormula.Value
    
    Cells(1, whatColumn).CurrentRegion.Columns.AutoFit
    Cells(1, whatColumn).CurrentRegion.AutoFilter
    
    'Make a copy of the data to a new workbook
    shtNbr = wksTemp.Index
    Sheets(shtNbr).Select
    Sheets(shtNbr).Copy After:=Worksheets(Worksheets.Count)
    Set wkshtDupes = ActiveSheet
    wkshtDupes.Name = "Duplicates_" & Worksheets.Count
    
    'Set autofilter to non duplicates then delete them.
    Cells(1, whatColumn).CurrentRegion.AutoFilter Field:=whatColumn + 1, Criteria1:="=1", Operator:=xlAnd
    Range(rngTop.Address, rngTop.End(xlDown).Address).EntireRow.Delete
    
    'Switch off the autofilter and remove the duplicate column
    Selection.AutoFilter
    Columns(whatColumn + 1).Delete Shift:=xlToLeft
    
    'Go Back to the orginal sheet to delete the duplicates
    wksTemp.Select
    
    'Set autofilter to duplicates then delete them.
    Cells(1, whatColumn).CurrentRegion.AutoFilter Field:=whatColumn + 1, Criteria1:="<>1", Operator:=xlAnd
    Range(rngTop.Address, rngTop.End(xlDown).Address).EntireRow.Delete
    
    'Switch off the autofilter and remove the duplicate column
    Selection.AutoFilter
    Columns(whatColumn + 1).Delete Shift:=xlToLeft
    
    'Report back a success
    MoveALL_Dupes = True
End Function

simplest is to count them .
in a spare column on the same row assuming data starts in b2
=countif(B:B,B2)>1
auto fill down to end of data in col b
now filter that column by false
you can now delete those rows in on go
or else filter on true and copy visible rows to somewhere else to work on

on re -reading this i see you are already using advanced filter since you know how to do it why not reverse the criteria so as to filter on those you dont want, then simply delete the entire lot of visible rows