Macro to copy duplicate rows (not delete)

[miasmal]

Hello,

I have unsorted data (and needs to stay unsorted, so no autofilter/sort
on original data) that I want to copy all duplicate rows into another
sheet based on a column value. Example:


A B C ...
1 x a a
2 z b b
3 x c c
4 y d d
5 z e e
6 r f f
7 x g g
....


Using column A as criterion for duplicates. There are 3 instances of x
and 2 instances of z that will need to be copied. Another worksheet
would then contain:


A B C
1 x a a
2 x c c
3 x g g
4 z b b
5 z e e


I have been looking at other macros that are prevalent in this
newsgroup that DELETE duplicate rows. However, I do not want to delete
anything, or modify the original worksheet for that matter. Since I do
not know the # of times a particular value in the column would be
duplicated, I'm not sure a 2 FOR/LOOP type statements ala bubble-sort
type method would work?

The method I'm employing as a workaround is to use an empty column and
do:
IF((COUNTIF($A:$A, A1)>1), "dupe", "")
...and then let a macro copy & paste all rows that show "dupe" value.
Ideally I would like to omit this step.


Thanks,
-jzk

 

[Tom Ogilvy]

Sub ABC()
Dim rng As Range, rng1 As Range
Dim i As Long
With Worksheets("Sheet1")
Set rng = .Range("A1").CurrentRegion
End With
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
With Worksheets("Sheet2")
Set rng1 = .Range(rng.Address).Resize(, 1)
For i = rng.Rows.Count To 1 Step -1
If Application.CountIf(rng1, .Cells(i, 1)) = 1 Then
.Rows(i).Delete
End If
Next
End With
End Sub