Move Duplicates from Sheet1 to Sheet2

Try this one

Sub VenA()
Application.ScreenUpdating = False
With Sheets(1)
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For Each cl In Range("q1:q" & lr)
        cl.Value = Application.CountIf(Range("A1:A" & lr), cl.Offset(, -16).Value)
    Next cl
    .Range("A1:q1").AutoFilter 17, ">1"
    .Cells(1).CurrentRegion.Resize(, 16).SpecialCells(12).Copy Sheets(2).[A1]
    .Cells(1).CurrentRegion.Offset(1).Rows.EntireRow.Delete
    .Range("A1:q1").AutoFilter
    .Columns(17).Delete
    .Cells(1).CurrentRegion.Sort .[A1], Header:=xlYes
    With Sheets(2)
        .Cells(1).CurrentRegion.Sort .[A1], Header:=xlYes
    End With
End With
End Sub