Remove ALL duplicates, do not keep unique, and copy all duplicates to new sheet.

[newtoexL]

Hello,

There's several examples of "remove duplicates" and "remove duplicate and delete row" and "remove duplicate and delete row/copy row to new sheet".
However, I want to remove all pairs that are duplicates to a new sheet. So if,

Originals Rows that contain:
Jane
Jane
John
Jack

Then "Remove" all Jane and keep rows with:

John
Jack

With new sheet of rows:
Jane
Jane

Below is a sample of code that shows up a lot for remove duplicates and move duplicates. but keeps all the "unique" rows.

Sub CutDuplicates()
    Dim xRgS As Range
    Dim xRgD As Range
    Dim I As Long, J As Long
    On Error Resume Next
    Set xRgS = Application.InputBox("Please select the column:", "Column", Selection.Address, , , , , 8)
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Application.InputBox("Please select a desitination cell (first cell of column):", "New Area. Cell only", , , , , , 8)
    If xRgD Is Nothing Then Exit Sub
    xRows = xRgS.Rows.Count
    J = 0
    For I = xRows To 1 Step -1
        If Application.WorksheetFunction.CountIf(xRgS, xRgS(I)) > 1 Then
            xRgS(I).EntireRow.Copy xRgD.Offset(J, 0)
            xRgS(I).EntireRow.Delete
            J = J + 1
        End If
    Next
End Sub

 

[Coding4Fun]

Maybe something like this

Sub CutDuplicates()


' Looks at Column A(1) for the list to loop through
myCount = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row


' Inserting a count to determine the duplicate rows to keep and move
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Range("B1").FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
Range("B1").AutoFill Destination:=Range("B1:B" & myCount)
Range("B1:B" & myCount).Copy
Range("B1:B" & myCount).PasteSpecial xlPasteValues


'Loop through the values and move them or delete them if unique
Do Until myCount <= 1
    
    myCount = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    If Range("B1").Value > 1 Then
    Rows("1:1").Copy
    myCount2 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1
    Sheets("Sheet2").Range("A" & myCount2).PasteSpecial xlPasteValues
    Rows("1:1").Delete xlShiftUp
    ElseIf Range("B1").Value <= 1 Then
    Rows("1:1").Delete xlShiftUp
    End If
    
Loop


End Sub

 

[kvsrinivasamurthy]

Try this code

Sub RemoveDuplicates()On Error GoTo line1


Dim IPrng As Range, cel As Range
Dim DelStr As String


ActiveSheet.Copy Before:=ActiveSheet


Set IPrng = Range(InputBox("Enter the Range:" & Chr(10) & "EG: A3:A25", "RANGE"))


If IPrng.Columns.Count = 1 Then
 
 For Each cel In IPrng
    
    If WorksheetFunction.CountIf(IPrng, cel.Value) > 1 Then
    DelStr = DelStr & "," & cel.Address
    End If
 
 Next cel


If DelStr <> "" Then
DelStr = Mid(DelStr, 2)
Range(DelStr).EntireRow.Delete
End If


End If
line1:
End Sub

 

[Coding4Fun]

.

 

[Coding4Fun]

I think one should do the trick, I missed that you wanted to move the duplicates to a new sheet AND keep the unique values in the original sheet.

Sub CutDuplicates()

myCount = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

OnRow = 1

ValChecked = 1

' Inserting a count to determine the duplicate rows to keep and move
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Range("B1").FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
Range("B1").AutoFill Destination:=Range("B1:B" & myCount)
Range("B1:B" & myCount).Copy
Range("B1:B" & myCount).PasteSpecial xlPasteValues

Do Until ValChecked > myCount
    
    If Range("B" & OnRow).Value > 1 Then
        Rows(OnRow & ":" & OnRow).Copy
        myCount2 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1
        Sheets("Sheet2").Range("A" & myCount2).PasteSpecial xlPasteValues
        Rows(OnRow & ":" & OnRow).Delete xlShiftUp
    ElseIf Range("B" & OnRow).Value <= 1 Then
        OnRow = OnRow + 1
    End If
    
    ValChecked = ValChecked + 1
    
Loop

End Sub

 

[kvsrinivasamurthy]

To keep only duplicates and remove unique values try this code.

Sub RemoveDuplicates()On Error GoTo line1


Dim IPrng As Range, cel As Range
Dim DelStr As String


ActiveSheet.Copy Before:=ActiveSheet


Set IPrng = Range(InputBox("Enter the Range:" & Chr(10) & "EG: A3:A25", "RANGE"))


If IPrng.Columns.Count = 1 Then
 
 For Each cel In IPrng
    
    If WorksheetFunction.CountIf(IPrng, cel.Value) = 1 Then
    DelStr = DelStr & "," & cel.Address
    End If
 
 Next cel


If DelStr <> "" Then
DelStr = Mid(DelStr, 2)
Range(DelStr).EntireRow.Delete
End If


End If
line1:
End Sub

 

[Coding4Fun]

Hello,

There's several examples of "remove duplicates" and "remove duplicate and delete row" and "remove duplicate and delete row/copy row to new sheet".
However, I want to remove all pairs that are duplicates to a new sheet. So if,

Originals Rows that contain:
Jane
Jane
John
Jack

Then "Remove" all Jane and keep rows with:

John
Jack

With new sheet of rows:
Jane
Jane

To keep only duplicates and remove unique values try this code.

Sub RemoveDuplicates()On Error GoTo line1


Dim IPrng As Range, cel As Range
Dim DelStr As String


ActiveSheet.Copy Before:=ActiveSheet


Set IPrng = Range(InputBox("Enter the Range:" & Chr(10) & "EG: A3:A25", "RANGE"))


If IPrng.Columns.Count = 1 Then
 
 For Each cel In IPrng
    
    If WorksheetFunction.CountIf(IPrng, cel.Value) = 1 Then
    DelStr = DelStr & "," & cel.Address
    End If
 
 Next cel


If DelStr <> "" Then
DelStr = Mid(DelStr, 2)
Range(DelStr).EntireRow.Delete
End If


End If
line1:
End Sub

I dont think this is meeting the requirement, you are creating a copy of the original and then deleting the unique values which leaves you with just the duplicates but the user is asking to MOVE and DELETE the duplicates from the original list.

The code I submitted in post #5 does what the user is asking unless I am misunderstanding their requirements.