Ranking code with system reserved numbers (upgraded version needed) - VBA

[kelly mort]

This request is following the solution provided by @Akuini in post #35 at:

Ranking Code Amendment With System Reserved Numbers -vba

I want to set some numbers as system numbers to use against the ranking as done by the code below. Currently, I am using three numbers – 100, 95 and 90. In the future, I may reduce (say 2 numbers) or increase (say 5 or more numbers). And in each scenario, the aim is to make those numbers take...

www.mrexcel.com

I just run into a problem and I will require your help to fix it.

I was previously dealing with whole numbers but now I am using both whole numbers and decimals.
Then when I run the code, it fails to give me the ranks for the floating point numbers. It produces blanks for all the decimal numbers.

So I changed the types of the variables z& to z# and Rnk& to Rnk# but the issue is still not resolved.

I have been staring at the screen since – but I can’t seem to fix it.
How do I get around with that?

This part of the code is storing the various numbers to be used like 100, 90, 75 etc.

ary = Split(Trim(SysScore))

The rest of the code is below. And this is the full code that I have been using for the ranking.

Sub RankSystem()
    Dim d As Object, m&, qr&, qq&, hh&, xq&, xz&, ary, i&
    
    Application.ScreenUpdating = False
    With Sheets("Data")
        qq = .Range("C" & Rows.Count).End(xlUp).Row
        For qr = 7 To qq
            m = WorksheetFunction.CountIf(.Range("C7:C" & qq), .Range("C" & qr))
           
                    ary = Split(Trim(SysScore))
                    ary = Application.Transpose(Application.Transpose(ary))
                    Set d = CreateObject("scripting.dictionary")
                    For i = 1 To UBound(ary)
                        d(CLng(ary(i))) = Empty
                    Next i
                    
                    Call toRank(qr, m, d, 4, 13, ary)
        
                    hh = 0
                    For xq = qr To qr + m - 1
                        xz = WorksheetFunction.CountA(.Range("D" & xq & ":" & "M" & xq))
                        If xz > hh Then hh = xz
                    Next xq
    
                    ary = Split(Trim(SysScore))
                    
                    For i = 0 To UBound(ary)
                        ary(i) = ary(i) * hh
                    Next i
                    
                    ary = Application.Transpose(Application.Transpose(ary))
                    Set d = CreateObject("scripting.dictionary")
                    For i = 1 To UBound(ary)
                        d(CLng(ary(i))) = Empty
                    Next i
                    Call toRank(qr, m, d, 14, 14, ary)
               
            qr = qr + m - 1
        Next qr
    End With
    Application.ScreenUpdating = True
End Sub

Sub toRank(qr&, m&, d As Object, a&, b&, ary)
    Dim i&, z#, N&, yy&, g&, arz, arb
    Dim e As Object, f As Object, c As Range, r As Range, ra As Range
    
    With Sheets("Data")
        For g = a To b
            Set r = .Cells(qr, g).Resize(m)
            yy = WorksheetFunction.CountA(r)
            i = 0
            If yy > 0 Then
                ReDim arb(1 To yy)
                For Each ra In r
                    If Len(ra) > 0 Then
                        i = i + 1
                        arb(i) = ra
                    End If
                Next ra
            Else
                GoTo skip:
            End If
        
            ReDim arz(1 To UBound(arb))
            For i = 1 To UBound(arb)
                arz(i) = WorksheetFunction.Large(arb, i)
            Next i
            N = arz(UBound(arz))
            Set e = CreateObject("scripting.dictionary")
            For i = 1 To UBound(arz)
                e(arz(i)) = e(arz(i)) + 1
            Next i
    
            Set f = CreateObject("scripting.dictionary")
            z = 1
            For i = ary(1) To N Step -1
                If d.exists(i) And Not e.exists(i) Then
                    z = z + 1
                End If
'
                If e.exists(i) Then
                    f(i) = z & GetSuffix(z)
                    z = z + e(i)
                End If
            Next i
    
            For Each c In .Cells(qr, g).Resize(m)
                If f.exists(c.Value) Then c.Offset(, 14) = f(c.Value)
            Next c
skip:
        Next g
    End With
End Sub

Function GetSuffix(Rnk#) As String
Dim sSuffix$
If Rnk Mod 100 >= 11 And Rnk Mod 100 <= 20 Then
sSuffix = " th"
Else
Select Case (Rnk Mod 10)
Case 1: sSuffix = " st"
Case 2: sSuffix = " nd"
Case 3: sSuffix = " rd"
Case Else: sSuffix = " th"
End Select
End If
GetSuffix = sSuffix
End Function

 

[kelly mort]

​

By which way real 'sysCore' is defined : only with hardcoding it or ?​

No I have it fed into the system by an input box - that script is there intact - also provided by @Akuini

 

[Akuini]

except those 3rd ranks which should have been 4th instead and the subsequent ones adjusted as well.

SysScore= "90 89 87"

1. Why 85.33 is rank 8, in syscore there is 87, so shouldn't it be rank 9?
2. There's 90 in SysScore and three 90 in the data, should we count there are four 90, so 89 get rank 8 not 7?

demo_workbook_for_ranking_code_amendment 1.xlsm
	B	C	D	E	F
6		N1			RESULT
7	1	93			1 st
8	2	91			2 nd
9	2	91			2 nd
10	4	90			4 th
11	4	90			4 th
12	4	90			4 th
13	7	89			7 th
14	8	85.33			9 th
15	9	83.5			10 th
16	10	83			11 th
17	11	78.5			12 th
Sheet2

 

[kelly mort]

You are correct - that was an oversight on my part

 

[Akuini]

Are you answering yes to both question?
Try this one:

Sub RankSystem()
    Dim scA As Object, va, vb, vc, x
    Dim v As Long
    Application.ScreenUpdating = False
        SysScore = "90 89 87"
        qq = Range("C" & Rows.Count).End(xlUp).Row
        va = Range("C7", Cells(Rows.Count, "C").End(xlUp))
        
        Set scA = CreateObject("System.Collections.ArrayList")
    
        For Each x In va
            scA.Add CDbl(x)
        Next

        For Each x In Split((SysScore))
            scA.Add CDbl(x)
        Next
        
        scA.Sort
        scA.Reverse
        
        ReDim vb(1 To scA.Count, 1 To 2)
        i = 0
        
        For Each x In scA
            i = i + 1
            vb(i, 1) = x
        Next
        
        vb(1, 2) = 1 & " " & "st"
        v = 1
        For i = 2 To UBound(vb, 1)
            v = v + 1
            If vb(i, 1) = vb(i - 1, 1) Then
                vb(i, 2) = vb(i - 1, 2)
            Else
                vb(i, 2) = v & " " & GetSuffix(v)
                
            End If
        Next
                
        ReDim vc(1 To UBound(va, 1), 1 To 1)
        
        For i = 1 To UBound(va, 1)
            For j = 1 To UBound(vb, 1)
                If va(i, 1) = vb(j, 1) Then
                    vc(i, 1) = vb(j, 2)
                    Exit For
                End If
            Next
        Next
                
        Range("F7").Resize(UBound(vc, 1), 1) = vc
 
    Application.ScreenUpdating = True
End Sub

demo_workbook_for_ranking_code_amendment 1.xlsm
	C	D	E	F
6	N1			RESULT
7	93			1 st
8	91			2 nd
9	91			2 nd
10	90			4 th
11	90			4 th
12	90			4 th
13	89			8 th
14	85.33			11 th
15	83.5			12 th
16	83			13 th
17	78.5			14 th
18	78			15 th
19	77			16 th
20	76.5			17 th
21	76.5			17 th
22	76			19 th
23	76			19 th
24	58			21 st
Sheet2

 

[kelly mort]

2. There's 90 in SysScore and three 90 in the data, should we count there are four 90, so 89 get rank 8 not 7?

I want the 89 counted as 7 not 8 (only if it's possible that way)

 

[Akuini]

I want the 89 counted as 7 not 8 (only if it's possible that way)

Try:

Sub RankSystem()
    Dim scA As Object, va, vb, vc, x
    Dim v As Long
    Application.ScreenUpdating = False
        SysScore = "90 89 87"
        qq = Range("C" & Rows.Count).End(xlUp).Row
        va = Range("C7", Cells(Rows.Count, "C").End(xlUp))
        
        Set scA = CreateObject("System.Collections.ArrayList")
    
        For Each x In va
            scA.Add CDbl(x)
        Next

        For Each x In Split((SysScore))
            If Not scA.contains(CDbl(x)) Then scA.Add CDbl(x)
        Next
        
        scA.Sort
        scA.Reverse
        
        ReDim vb(1 To scA.Count, 1 To 2)
        i = 0
        
        For Each x In scA
            i = i + 1
            vb(i, 1) = x
        Next
        
        vb(1, 2) = 1 & " " & "st"
        v = 1
        For i = 2 To UBound(vb, 1)
            v = v + 1
            If vb(i, 1) = vb(i - 1, 1) Then
                vb(i, 2) = vb(i - 1, 2)
            Else
                vb(i, 2) = v & " " & GetSuffix(v)
                
            End If
        Next
                
        ReDim vc(1 To UBound(va, 1), 1 To 1)
        
        For i = 1 To UBound(va, 1)
            For j = 1 To UBound(vb, 1)
                If va(i, 1) = vb(j, 1) Then
                    vc(i, 1) = vb(j, 2)
                    Exit For
                End If
            Next
        Next
                
        Range("F7").Resize(UBound(vc, 1), 1) = vc
 
    Application.ScreenUpdating = True
End Sub

demo_workbook_for_ranking_code_amendment 1.xlsm
	C	D	E	F
6	N1			RESULT
7	93			1 st
8	91			2 nd
9	91			2 nd
10	90			4 th
11	90			4 th
12	90			4 th
13	89			7 th
14	85.33			9 th
15	83.5			10 th
16	83			11 th
17	78.5			12 th
18	78			13 th
19	77			14 th
20	76.5			15 th
21	76.5			15 th
22	76			17 th
23	76			17 th
24	58			19 th
Sheet2

 

[kelly mort]

Okay we are cool to move on with the switches x y z in column C.

 

[Akuini]

Ok, I'll try to finish the code tomorrow.

 

[kelly mort]

I am very grateful. Have wonderful time.

Tomorrow it is then.

 

[Akuini]

Ok, try this:
Note: Use this and "Function GetSuffix", you don't need "Sub toRank" anymore,

Sub RankSystem()
    Dim scA As Object, d As Object
    Dim va, vb, vc, x, z
    Dim i As Long, a1 As Long, a2 As Long, h As Long, j As Long
    Dim SysScore

Application.ScreenUpdating = False
   
SysScore = "90 89 87"
Range("R5") = "SysScore: " & SysScore

va = Range("C7", Cells(Rows.Count, "C").End(xlUp))
    Set d = CreateObject("scripting.dictionary")

    For i = 1 To UBound(va, 1)

        z = va(i, 1)
        If Not d.Exists(z) Then
            d(z) = 1
            d(z & ":") = i
        Else
            d(z) = d(z) + 1
        End If
    Next
    
       
For Each z In d.keys
    
    If InStr(z, ":") = 0 Then
        a1 = d(z & ":") 'row as start of category, 7 is 1
        a2 = d(z)       'length
    End If
    
    For h = 4 To 14 'col D:N
        'if column has data
        If Columns(h).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row > 6 Then
            va = Cells(6 + a1, h).Resize(a2)
            Set scA = CreateObject("System.Collections.ArrayList")
        
            For Each x In va
                If x <> "" Then scA.Add CDbl(x)
            Next
            
            For Each x In Split((SysScore))
                If IsNumeric(x) Then
                    If Not scA.contains(CDbl(x)) Then scA.Add CDbl(x)
                End If
            Next
            
            scA.Sort
            scA.Reverse
            
            ReDim vb(1 To scA.Count, 1 To 2)
            i = 0
            
            For Each x In scA
                i = i + 1
                vb(i, 1) = x
            Next
            
            vb(1, 2) = 1 & " " & "st"
            
            For i = 2 To UBound(vb, 1)
                If vb(i, 1) = vb(i - 1, 1) Then
                    vb(i, 2) = vb(i - 1, 2)
                Else
                    vb(i, 2) = i & " " & GetSuffix(i)
                End If
            Next
                    
            ReDim vc(1 To UBound(va, 1), 1 To 1)
            
            For i = 1 To UBound(va, 1)
                For j = 1 To UBound(vb, 1)
                    If va(i, 1) = vb(j, 1) Then
                        vc(i, 1) = vb(j, 2)
                        Exit For
                    End If
                Next
            Next
                    
            Cells(6 + a1, h + 14).Resize(UBound(vc, 1), 1) = vc
        
        End If
    Next
Next
    Application.ScreenUpdating = True
End Sub

Example:

demo_workbook_for_ranking_code_amendment 1.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
6	ID	NAME	CAT	N1	N2	N3	N4	N5	N6	N7	N8	N9	N10	TOTAL
7	354		X	93	81	83	89	80.5		88	68		73	655.5
8	336		X	91	59	37.5	57	51.5	47.5	64	62		25	494.5
9	338		X	89	67	52	73.5	58	78	69	41.5		64.5	592.5
10	356		X	85	69	51	72	57.5	82	80	53.5		66.5	616.5
11	339		X	76.5	51	55.5	72	60.5	70.5	75	53.5		63.5	578
12	23		X	64	84.5	73	87	79	83	87	65.5		76	699
13	361		X	64	90	90	93	83.5	90	90	86		84.5	771
14	362		X	62.5	70.5	62.5	74	68	38	74	65.5		71.5	586.5
15	341		Y	86	77	67	85.5	77	76	85	71.5		70.5	695.5
16	342		Y	76	77.5	58.5	75.5	74.5	89	79	52		65	647
17	363		Y	89	84.5	89	83	85	91	85	62		82	750.5
18	364		Y	91	82	79.5	86	75.5	81	85	62		77.5	719.5
19	30		Z	83.5	74	78		78.5	74	83	60		72	603
20	365		Z	77	60	65	75	63.5	81	75	44		62	602.5
21	27		Z	76.5	77.5	66.5	84	76.5	80.5	81	40		73	655.5
22	25		Z	78	77.5	86.5	83.5	79	78.5	81	71.5		71.5	707
23	343		Z	76	61.5	55	82	67.5	87	77	68		68	642
24	24		a	59	49	38.5	56.5	51.5	67.5	63	54		66.5	505.5
25	366		a	88.5	78	65.5	70	74	34	72	53.5		73.5	609
26	344		a	67	55	49	62.5	51.5	62.5	64			25	436.5
Sheet5

RESULT:

demo_workbook_for_ranking_code_amendment 1.xlsm
	R	S	T	U	V	W	X	Y	Z	AA	AB
5	SysScore: 90 89 87
6	RNK1	RNK2	RNK3	RNK4	RNK5	RNK6	RNK7	RNK8	RNK9	RNK10	RNK T
7	1 st	5 th	4 th	3 rd	5 th		3 rd	5 th		6 th	3 rd
8	2 nd	9 th	10 th	9 th	11 th	8 th	9 th	8 th		11 th	8 th
9	4 th	8 th	8 th	6 th	9 th	6 th	8 th	11 th		9 th	5 th
10	6 th	7 th	9 th	7 th	10 th	5 th	5 th	9 th		8 th	4 th
11	7 th	10 th	7 th	7 th	8 th	7 th	6 th	9 th		10 th	7 th
12	8 th	4 th	5 th	4 th	6 th	4 th	4 th	6 th		5 th	2 nd
13	8 th	1 st	1 st	1 st	4 th	1 st	1 st	4 th		4 th	1 st
14	10 th	6 th	6 th	5 th	7 th	9 th	7 th	6 th		7 th	6 th
15	5 th	7 th	5 th	5 th	5 th	6 th	4 th	4 th		6 th	3 rd
16	6 th	6 th	6 th	7 th	7 th	3 rd	7 th	7 th		7 th	4 th
17	3 rd	4 th	2 nd	6 th	4 th	1 st	4 th	5 th		4 th	1 st
18	1 st	5 th	4 th	4 th	6 th	5 th	4 th	5 th		5 th	2 nd
19	4 th	6 th	5 th		5 th	7 th	4 th	6 th		5 th	4 th
20	6 th	8 th	7 th	7 th	8 th	4 th	8 th	7 th		8 th	5 th
21	7 th	4 th	6 th	4 th	6 th	5 th	5 th	8 th		4 th	2 nd
22	5 th	4 th	4 th	5 th	4 th	6 th	5 th	4 th		6 th	1 st
23	8 th	7 th	8 th	6 th	7 th	3 rd	7 th	5 th		7 th	3 rd
24	6 th	6 th	6 th	6 th	5 th	4 th	6 th	4 th		5 th	2 nd
25	3 rd	4 th	4 th	4 th	4 th	6 th	4 th	5 th		4 th	1 st
26	5 th	5 th	5 th	5 th	5 th	5 th	5 th			6 th	3 rd
Sheet5