Three level ranking

[Raju Kumar Singh]

Hey guys..

Please help me to write a VBa code for the below scenario.

I have five columns. First one have names. 3rd, 4th, 4th have criteria. First, give ranking as per 3rd columns, if any output rank have same ranking then it will go to 4th column criteria. If after applying ranking again same ranks are there then will check with 5th column criteria. Final ranking will be kept in 2nd column.

Name	Rank	criteria 1	Criteria 2	Criteria 3
ARR		5	6	3
NET		8	1	9
JUNb		45	25	1
PRO		23	12	33
NEC		12	2	8
JUN		0	2	3
RKSI		15	32	3
JUNk		0	25	12
JUNe		3	12	20
TS		33	11	10
ING		0	0	23
DIM		4	15	13
JUNt		16	16	2
AVN		6	36	19
MAR		29	15	3
NIS		5	6	9
JUNx		22	11	0
PT.		0	0	15

<colgroup><col><col><col span="3"></colgroup><tbody>
</tbody>

Thanks...

 

[Eric W]

Do you need VBA? The following formula does what you want:

	A	B	C	D	E	F
1	Name	Rank	criteria 1	Criteria 2	Criteria 3
2	ARR	12	5	6	3
3	NET	9	8	1	9
4	JUNb	1	45	25	1
5	PRO	4	23	12	33
6	NEC	8	12	2	8
7	JUN	16	0	2	3
8	RKSI	7	15	32	3
9	JUNk	15	0	25	12
10	JUNe	14	3	12	20
11	TS	2	33	11	10
12	ING	17	0	0	23
13	DIM	13	4	15	13
14	JUNt	6	16	16	2
15	AVN	10	6	36	19
16	MAR	3	29	15	3
17	NIS	11	5	6	9
18	JUNx	5	22	11	0
19	PT.	18	0	0	15

<tbody>
</tbody>

Sheet4​

Worksheet Formulas Cell Formula B2 =SUMPRODUCT(--(C$2:C$19*10000+D$2:D$19*100+E$2:E$19>C2*10000+D2*100+E2))+1 <tbody> </tbody>

<tbody>
</tbody>

It should work as long as none of the values exceeds 100. If that's a possibility, raise the 100s in the formula to 1000, and the 10000s to 1000000.

 

[Raju Kumar Singh]

Thanks Eric..

Its awesome!! Is it possible to get the same output with the help of VBA code as well?

 

[Eric W]

Sure:

Sub rank1()
Dim lr As Long, MyData As Variant, i As Long, j As Long

    lr = Cells(Rows.Count, "A").End(xlUp).Row
    MyData = Range("A2:E" & lr).Value
    For i = 1 To UBound(MyData)
        MyData(i, 2) = 1
        For j = 1 To UBound(MyData)
            If MyData(j, 3) < MyData(i, 3) Then GoTo NextJ:
            If MyData(j, 3) > MyData(i, 3) Then
                MyData(i, 2) = MyData(i, 2) + 1
                GoTo NextJ:
            End If
            If MyData(j, 4) < MyData(i, 4) Then GoTo NextJ:
            If MyData(j, 4) > MyData(i, 4) Then
                MyData(i, 2) = MyData(i, 2) + 1
                GoTo NextJ:
            End If
            If MyData(j, 5) > MyData(i, 5) Then MyData(i, 2) = MyData(i, 2) + 1
NextJ:
        Next j
    Next i
    Range("A2:E" & lr).Value = MyData
        
End Sub

 

[Raju Kumar Singh]

Wow!! Thanks a lot, Eric!!

 

[Eric W]

You're welcome!

 

[Eric W]

I've been playing around with ArrayLists, and here's a case where using one results in a shorter macro, which I'll present for interest:

Sub rank2()
Dim i As Long, AL As Object

    Set AL = CreateObject("System.Collections.ArrayList")
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        AL.Add Format(Cells(i, 3), "00") & Format(Cells(i, 4), "00") & Format(Cells(i, 5), "00") & Cells(i, 1)
    Next i
    AL.Sort
    AL.Reverse
    For i = 0 To AL.Count - 1
        Range("A1:A19").Find(Mid(AL.Item(i), 7), , , xlWhole).Offset(, 1) = i + 1
    Next i
    
End Sub

 

[Peter_SSs]

Its awesome!! Is it possible to get the same output with the help of VBA code as well?

In that case, couldn't we just apply Eric's formula approach through vba?

Sub Rank0()
  With Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
    .Formula = Replace("=SUMPRODUCT(--(C$2:C$#*10000+D$2:D$#*100+E$2:E$#>C2*10000+D2*100+E2))+1", "#", Range("A" & Rows.Count).End(xlUp).Row)
    .Value = .Value
  End With
End Sub

 

[Eric W]

Hi Raju,

the concept behind the formula is simple, for any row, just count the number of other rows that are outrank this row, and that's the rank. If you have a row with 0 others that outrank it, it's rank is 0 + 1. If you have a row where 2 other rows outrank it, it's rank is 2 + 1, or 3.

To make comparing ranks easy, we combine all 3 criteria into a single value. For example, row 8 RKSI, the criteria are 15, 32, and 3. Multiply 15 by 10000 = 150000, multiply 32 by 100 = 3200, and add them together 150000 + 3200 + 3 = 153203. Compare that to another row, say 161602 (row 14), and it's easy to see that row 14 is bigger. If there is a tie in the first criteria, like 50603 and 50609 (rows 2 and 17) you can see row 17 wins, but it has to go to the third criteria.

Finally, now that we see the basic idea, we just have to find a way to compare all the rows at a time. The SUMPRODUCT is an array function, it lets you perform actions on a range of data.

=SUMPRODUCT(--(C$2:C$19*10000+D$2:D$19*100+E$2:E$19>C2*10000+D2*100+E2))+1

The part in red calculates the number for the entire range, the part in blue calculates the number for an individual row. This results in 18 comparisons, giving 18 TRUE/FALSE answers. The -- is called a double unary and basically converts TRUE/FALSE into 1/0. Then the SUM part of SUMPRODUCT adds up the 1s, and we add the extra 1, and we're done.

Hope this explains things for you.

Peter, your implementation of the macro is shorter, and no doubt more efficient than either of my versions. But the OP wanted a "different" solution than a formula, so I decided to try an approach that's not just a reconfiguration of the formula. Both of my versions can be improved, but I did learn something in the process so that's a plus for me anyway.

 

[Peter_SSs]

Peter, your implementation of the macro is shorter, and no doubt more efficient than either of my versions. But the OP wanted a "different" solution than a formula, so I decided to try an approach that's not just a reconfiguration of the formula. Both of my versions can be improved, but I did learn something in the process so that's a plus for me anyway.

Hi Eric, I'm not sure about the "different" solution desire but trying something different is often rewarding.

I do note that your ArrayList macro does not produce the same results as the SUMPRODUCT formula. Test where there are 2 or more rows with identical criteria, as with rows 2 & 3 in my sample below.

Here is a similar idea but using a SortedList instead of an ArrayList.
I have assumed that if there are ties, the rows are ranked equally and then the next rank(s) are skipped until a different set of criteria is encountered, like the SUMPRODUCT formula did.

Sub rank2a()
  Dim i As Long
  Dim SL As Object
  Dim s As String

  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    s = Format(Cells(i, 3), "00") & Format(Cells(i, 4), "00") & Format(Cells(i, 5), "00")
    If SL.ContainsKey(s & "-9999") Then
      SL.Add s & Format(i, "-0000"), 1
    Else
      SL.Add s & "-9999", 1
    End If
  Next i
  For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    Cells(i, 2).Value = SL.Count - SL.IndexOfKey(Format(Cells(i, 3), "00") & Format(Cells(i, 4), "00") & Format(Cells(i, 5), "00") & "-9999")
  Next i
End Sub

My sample data and code results:

Book1
	A	B	C	D	E
1	Name	Rank	criteria 1	Criteria 2	Criteria 3
2	ARR	11	5	6	3
3	NET	11	5	6	3
4	JUNb	1	45	25	1
5	PRO	4	23	12	33
6	NEC	8	12	2	8
7	JUN	16	0	2	3
8	RKSI	7	15	32	3
9	JUNk	15	0	25	12
10	JUNe	14	3	12	20
11	TS	2	33	11	10
12	ING	17	0	0	23
13	DIM	13	4	15	13
14	JUNt	6	16	16	2
15	AVN	9	6	36	19
16	MAR	3	29	15	3
17	NIS	10	5	6	9
18	JUNx	5	22	11	0
19	PT.	18	0	0	15
Rank (2)