Cut, paste and delete

[Daminc]

I'm trying to make a varient macro of the 'delete duplicates' theme.

My co-worker wants a record of the duplicate rows that have been
deleted.
I've made some progress but I'm having difficulties in deleting the
rows that have been cut/pasted.


Code:
--------------------
Sub DeleteDupRow()
'
'
'Deletes row if there is
'a duplicate found in the
'column
'
Dim currentcell As Range
Dim nextcell As Range

Application.ScreenUpdating = False

Sheets.Add 'Adds new worksheet to the left
ActiveSheet.Name = "Duplicates" 'renames new worksheet
ActiveSheet.Next.Select 'moves one worksheet to the right

Set currentcell = ActiveCell

Do While Not IsEmpty(currentcell.Offset(0, 0))
Set nextcell = currentcell.Offset(1, 0)

If nextcell.Value = currentcell.Value Then
currentcell.EntireRow.Cut (Worksheets("Duplicates").Range("A65536").End(xlUp).Offset(1, 0))
End If

IF CURRENTCELL.VALUE < 1 THEN 'HERE BE AN ERROR TO BE SORTED OUT
CURRENTCELL.ENTIREROW.DELETE
END IF

Set currentcell = nextcell
Loop

Set currentcell = Nothing
Application.ScreenUpdating = True

End Sub
--------------------

The emboldened bit is just the latest variation of me experimenting
with solving this problem to no avail.

I originally thought the 'currentcell.EntireRow.Delete' should be below
the line ending in 'End(xlUp).Offset(1, 0))' but that didn't work.

Any advice to where I'm going wrong?

Thanks in advance

 

[Daminc]

This seems to work:


Code:
--------------------
Sub DeleteDupRow()
'
'
'Deletes row if there is
'a duplicate found in the
'column
'
Dim currentcell As Range
Dim nextcell As Range

Application.ScreenUpdating = False

Sheets.Add 'Adds new worksheet to the left
ActiveSheet.Name = "Duplicates" 'renames new worksheet
ActiveSheet.Next.Select 'moves one worksheet to the right

Set currentcell = ActiveCell

Do While Not IsEmpty(currentcell.Offset(0, 0))
Set nextcell = currentcell.Offset(1, 0)

If nextcell.Value = currentcell.Value Then
currentcell.EntireRow.Copy (Worksheets("Duplicates").Range("A65536").End(xlUp).Offset(1, 0))
End If

If nextcell.Value = currentcell.Value Then
currentcell.EntireRow.Delete
End If

Set currentcell = nextcell
Loop

Set currentcell = Nothing
Application.ScreenUpdating = True

End Sub