Sub ListDups()
Dim c As Range
Dim rng As Range
Dim rng2 As Range
Dim iRow As Long
Dim iEnd As Long
iEnd = Sheets("Sheet1").Range("A2").End(xlDown).Row
Set rng = Sheets("Sheet1").Range("A2:A" & iEnd)
iRow = 1
For Each c In rng
If Application.CountIf(rng, c) 1 Then
Set rng2 = Sheets("Sheet2").Range("A1:A" & iRow)
If IsError(Application.Match(c, rng2, 0)) Then
iRow = iRow + 1
Sheets("Sheet2").Cells(iRow, "A") = c
End If
End If
Next c
End Sub

Hth,
Merjet