Hi all, i have the following senario, i need to delete the duplicates
(Entire.Row) in column "A" but keeping the highest number in "B", as
indicated below.

A B

6771879 1 '<== Delete Row
6771879 2 '<== Delete Row
6771879 3 '<== Keep - duplicate but highest Nr in "B".
6774875 10 '<== Keep - Not duplicate in "A"
6775869 1 '== Keep - Not duplicate in "A"
6775970 1 '<== Delete Row
6775970 2 '<== Keep - duplicate but highest Nr in "B".
6775971 10 '== Keep - Not duplicate in "A"
6775975 12 '<== Delete Row
6775975 13 '<== Delete Row
6775975 14 '<== Keep - duplicate but highest Nr in "B".

I have the code below from Tom Ogilvy, but it is only keeping the
highest in "B" !!

Sub DeleteLcsDuplicates()
'
'------ With this i need to delete duplicate part numbers in "A" but --
'------ The lowest number in "B".
'------ This assumes you want to retain the part number with the highest
number in column B.
Dim iLastRow As Long
Dim i As Long, rng As Range
Dim rng1 As Range, s As String
Dim maxNum As Long
Set rng = Cells(Rows.Count, 1).End(xlUp)
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 2 Step -1
Set rng1 = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
If Application.CountIf(rng1, Cells(i, 1)) 1 Then
s = "Max(if(" & rng1.Address & "=" & Cells(i, 1).Address _
& "," & rng1.Offset(0, 1).Address & "))"
maxNum = Evaluate(s)
' Debug.Print i, Cells(i, 1), Cells(i, 2), maxNum
'---- If you want to retain the part with the smallest number, change
MAX to MIN
End If
If Cells(i, 2) < maxNum Then
Rows(i).Delete
End If
Next i
PctDone = Counter + 0.5 '---1
Call UpdateProgress(PctDone)
MoveCompFileToArchive
End Sub



Best regards,

Les Stout

*** Sent via Developersdex http://www.developersdex.com ***