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]

Hello @Akuini,
Here is the link to the workbook:

Dropbox

www.dropbox.com

And for the requirements, I am feeding the system with some numbers. Then I rank those numbers against the data that I have on my data sheet.

so say I feed the system with the numbers:

SysScore = "100 90"

Then, the ranking reserves those numbers, which means that if I have the numbers 89, 73, 84, 40 on my data sheet, their rank becomes, 3rd, 5th, 4th, 6th because the 1st was taken by the 100 and 2nd by the 90.

I remember during the time you were about to produce the code, you asked me if all the numbers will be integers and I said yes - not considering a day like today, when I will be dealing with both integers and floating numbers.


In order not to make you do double task, there is this issue here that I want to address.

The previous code was working on the logic that the "SysScore" will always start from 100. But I want to modify that logic in a way that it could be like this:

SysScore = "80 70"

And in that case if I have the numbers 89, 73, 84, 40 on my data sheet, their rank should be 1st, 4th, 2nd, 6th.

since the 89 and 84 are larger than the system score, they are ranked above them, 73 becomes 4th because the 80 (system number) has taken the 3rd place and the 40 became 6th because the 5th place has also been taken by the 70.

Thanks again for your time.

 

[Marc L]

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

Should be better with Currency data type …​

 

[kelly mort]

Should be better with Currency data type …​

I just changed the z# or z& to z As Currency and same for the Rnk but it still has the blanks for the decimal numbers.

Did it work at your end with the demo workbook?

 

[Marc L]

​

I was just thinking about the classic rounding issue …​

 

[Akuini]

@kelly mort
Sorry, I kind of forget what the code does (it's been more than a year).
So I rewrite code the from a fresh start.
I haven't finished it yet, but I need to know that I'm in the right track.
So here's the code I've got so far with a simple example, only 1 column without any category X,Y,Z.. etc.
But see if this is basically what you want.
Please try it with various SysScore .

Sub RankSystem()
    Dim scA As Object, va, vb, vc, x
    Dim v As Long
    Application.ScreenUpdating = False
        SysScore = "100 95 90"
        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)
            If vb(i, 1) = vb(i - 1, 1) Then
                vb(i, 2) = vb(i - 1, 2)
            Else
                v = v + 1
                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

Function GetSuffix(Rnk As Long) 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

Example:

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

 

[kelly mort]

Hi @Akuini ,

Thanks so much for the time and effort put into this script.

I ran the code and this line flagged an error "Automation Error"

   Set scA = CreateObject("System.Collections.ArrayList")

Do I have to install or activate something?

 

[Akuini]

You might need to install .NET Framework 3.5 on your Windows.
See this discussion:

automation error -2146232576 (80131700) on creating an array

I have a macro that's working on one computer just fine, however when I try to run it on another computer I get the following error: Run-time error '-2146232576 (80131700)' Automation error Here'...

stackoverflow.com

 

[kelly mort]

1​	93​			1 st
2​	91​			2 nd
2​	91​			2 nd
4​	90​			3 rd
4​	90​			3 rd
4​	90​			3 rd
7​	89​			4 th
8​	85.33​			6 th
9​	83.5​			7 th
10​	83​			8 th
11​	78.5​			9 th
12​	78​			10 th
13​	77​			11 th
14​	76.5​			12 th
14​	76.5​			12 th
16​	76​			13 th
16​	76​			13 th
18​	58​			14 th

hi @Akuini,

I am done with the installation and it ran fine. I sorted the sample data(so that I can see things properly) you used and used sysScore = "90 89 87"
so far you are on the track, except those 3rd ranks which should have been 4th instead and the subsequent ones adjusted as well.

 

[Marc L]

​

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