delete duplicates macro to color instead of delete

[DKY]

I have this macro I found online. Once I sort my sheet by the column of
the selection that I'm' about to make (it has to be sorted) I then
select all the data in that column and this macro runs through and
deletes rows in which there are duplicate numbers. I'm trying to edit
it so that instead of deleting it colors it so I can decide what to do
from there. Here's the code.

Code:
--------------------
Public Sub DELETE_DUPLICATE_ROWS()
'
' This macro deletes duplicate rows in the selection. Duplicates are
' counted in the COLUMN of the active cell.

Dim col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

col = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set rng = Selection
Else
Set rng = ActiveSheet.UsedRange.Rows
End If

N = 0
For r = rng.Rows.Count To 1 Step -1
V = rng.Cells(r, 1).Value
If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
rng.Rows(r).EntireRow.delete
N = N + 1
End If
Next r

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

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


I try and replace the
rng.Rows(r).EntireRow.delete
with
rng.Rows(r).EntireRow.ColorIndex = 36
and the macro doesn't work right. It runs until it finds a duplicate
then it Ends the Macro. Does anyone know why my snippet of code is
stopping this from running correctly?

 

[JE McGimpsey]

Take a look here:

http://cpearson.com/excel/duplicat.htm

 

[Tom Ogilvy]

Public Sub DELETE_DUPLICATE_ROWS()
'
' This macro deletes duplicate rows in the selection. Duplicates are
' counted in the COLUMN of the active cell.

Dim col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

col = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set rng = Selection
Else
Set rng = ActiveSheet.UsedRange.Rows
End If

N = 0
For r = rng.Rows.Count To 1 Step -1
V = rng.Cells(r, 1).Value
If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
rng.Rows(r).EntireRow.Interior.ColorIndex = 5
N = N + 1
End If
Next r

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[DKY]

Thank you Tom, that works beautifull

 

[Guest]

Hello Tom
you may be able to help me! Im tearing my hair out trying to manually
delete rows of data that is only exactly duplicated in two columns because of
typos etc ie Column C contains an exact duplicate of the entered data as
does column J. I need a macro to recognise the duplicates in the
corresponding row of C and J columns and then delete one of the rows.
The programming below looks like it may be tweaked so that it will say ' If
the duplicated cells in J are also duplicated cells in C-delete'
Column C contains duplicated names Column J contains duplicated codes that
are a mix of text and numbers.

Public Sub DELETE_DUPLICATE_ROWS()
'
' This macro deletes duplicate rows in the selection. Duplicates are
' counted in the COLUMN of the active cell.

Dim col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

col = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set rng = Selection
Else
Set rng = ActiveSheet.UsedRange.Rows
End If

N = 0
For r = rng.Rows.Count To 1 Step -1
V = rng.Cells(r, 1).Value
If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
rng.Rows(r).EntireRow.Interior.ColorIndex = 5
N = N + 1
End If
Next r

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub