Sub RemoveDubeRows()
    Dim lr As Long, r As Long, wr As Long
Application.ScreenUpdating = False
'row to write to
wr = Sheets("dupesheet").Cells(Rows.Count, 1).End(xlUp).Row + 1
'rows to check for dupes
With Sheets("Sheet1")
    'last row
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    'start at bottom row and work up
    For r = lr To 2 Step -1
        If .Cells(r, 1) = .Cells(r - 1, 1) Then
            'compare the two rows
            '  credit Tim Williams ~~~ with great explanation at
            '  http://stackoverflow.com/questions/19395633/how-to-compare-two-entire-rows-in-a-sheet
            If Join(Application.Transpose(Application.Transpose(.Cells(r, 1).EntireRow.Value)), "") = _
               Join(Application.Transpose(Application.Transpose(.Cells(r - 1, 1).EntireRow.Value)), "") Then
                'copy and delete if equal
                .Cells(r, 1).EntireRow.Copy Sheets("dupesheet").Cells(wr, 1)
                .Cells(r, 1).EntireRow.Delete
                wr = wr + 1
            End If
        End If
    Next r
End With
Application.ScreenUpdating = True
End Sub