Delete all but highest value duplicate

[davroa]

Hi

I have 2 columns A & B. A has many duplicates and B has numerical values. I would like to delete all duplicates in A apart from the ones highest value in B
Please can someone help?

Thanks
Davroa

 

[GRCArizona]

Hi - put this code in the VBA Editor. If you need me to send you the file, just let me know.

Sub Delete_Lower_Values()

Range("A1:B1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A200"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2:B200"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:B200")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F200"), Type:=xlFillDefault

Range("A1:F200").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$F$8").AutoFilter Field:=6, Criteria1:="="
Rows("3:200").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$1:$f$200").AutoFilter Field:=6
Range("C1").Select
Selection.AutoFilter
Range("G4").Select
End Sub

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG01Oct12
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] omax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Mn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .Keys
    omax = Application.max(.Item(k).Offset(, 1))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Mn [COLOR="Navy"]In[/COLOR] .Item(k)
        [COLOR="Navy"]If[/COLOR] Not Mn.Offset(, 1) = omax [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Mn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Mn)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Mn
 [COLOR="Navy"]Next[/COLOR] k
nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] nRng = Nothing
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, ""
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[davroa]

Thanks to all:
This is the simplest solution I could find which works fine (Applies to my previous posted table:

• Sort column A ascending and sort scores B descending
• Insert the following formula in new column F
• =IF((A2=A1),”-“,”KEEP”)
• Autoformat F and select KEEP

davroa