Sub Rearrange()
    Dim wsSrc As Worksheet: Set wsSrc = Sheets("Sheet1")
    Dim wsDest As Worksheet: Set wsDest = Sheets("Sheet2")
    Dim lrSrc As Long: lrSrc = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
    Dim lrDest As Long: lrDest = wsDest.Range("A" & Rows.Count).End(xlUp).Row
    
    Const sFormula As String = "=COUNTIF($A$2:$A$#,A2)"
    
    Application.ScreenUpdating = False
    
    wsSrc.Range("A2:A" & lrSrc).Copy wsDest.Range("A" & lrDest + 1)
    
    With wsDest
        .Range("B1").Value = "Hdr"
        lrDest = .Range("A" & Rows.Count).End(xlUp).Row
        With .Range("B2").Resize(lrDest - 1)
            .Formula = Replace(sFormula, "#", lrDest)
            .Value = .Value
        End With
        With .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
            .AutoFilter Field:=1, Criteria1:=">1"
            .Offset(1).EntireRow.Delete
            .AutoFilter
        End With
        .Columns(2).EntireColumn.Delete
    End With

    Application.ScreenUpdating = True
End Sub