Rank the Minimum/Average Values in a Table with Duplicates

[studious]

I am trying to rank values in a table that has duplicate names:

Code	Var1
123	1
123	1.5
222	3
222	3.5
222	4
333	1
333	2

<tbody>
</tbody>

The output should look like this:

Code	Rank
123	1
222	3
333	2

<tbody>
</tbody>

Is there a clever way to do it instead of going through another table that takes the minimum/average for each unique 'Code' and then ranking these?

Thank you!

 

[decadence]

Perhaps this...

Sub RemoveDuplicates()
'
' Remove Duplicates Rows by Selecting Column
'
Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(Rng.row, "#,##0")
N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
    Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = Rng.Cells(R, 1).Value
  If V = vbNullString Then
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
  Else
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

This will delete the duplicate rows based on the column you select. However it's not clear on what data you want to keep

 

[MickG]

Try this for results starting "D1"

[COLOR="Navy"]Sub[/COLOR] MG23Nov56
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Dn.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        Dic(Dn.Value) = Dic(Dn.Value) + Dn.Offset(, 1).Value
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Range("D1:E1").Value = Array("Code", "Var1")
 [COLOR="Navy"]Set[/COLOR] Rng = Range("D2").Resize(Dic.Count, 2)
    Rng.Value = Application.Transpose(Array(Dic.keys, Dic.items))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Columns(2).Cells
        Dn.Value = Application.Rank(Dn, Rng.Columns(2).Cells, 1)
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[MickG]

If you require the rankings results in same columns "A & B" then try this:-

[COLOR="Navy"]Sub[/COLOR] MG23Nov15
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Dn.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        Dic(Dn.Value).Value = Dic(Dn.Value) + Dn.Offset(, 1).Value
        [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Dn.Value = Application.Rank(Dn, Rng, 1)
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[studious]

Thanks! Great solutions, guys.

 

[Eric W]

Just for fun, here's a formula based solution:

	A	B	C	D	E
1	Code	Var1		Code	Rank
2	123	1		123	1
3	123	1.5		222	3
4	222	3		333	2
5	222	3.5
6	222	4
7	333	1
8	333	2

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet3​

Array Formulas Cell Formula D2 {=IF(D1="","",IFERROR(INDEX($A$2:$A$8,SMALL(IF(MATCH($A$2:$A$8,$A$2:$A$8,0)=ROW($A$2:$A$8)-ROW($A$2)+1,ROW($A$2:$A$8)-ROW($A$2)+1),ROWS($D$2:$D2))),""))} E2 {=IF(D2="","",SUM(IF(AVERAGEIF($A$2:$A$8,D2,$B$2:$B$8)>IF(MATCH($A$2:$A$8,$A$2:$A$8,0)=ROW($A$2:$A$8)-ROW($A$2)+1,AVERAGEIF($A$2:$A$8,$A$2:$A$8,$B$2:$B$8)),1))+1)} <thead> </thead><tbody> </tbody> Entered with Ctrl+Shift+Enter. If entered correctly, Excel will surround with curly braces {}. Note: Do not try and enter the {} manually yourself

<tbody>
</tbody>