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]

Thanks so much @Akuini,

This new version of the code is amazing.

so I wrapped the code inside a with block

With Sheets("Data")
''''''''''''''''''''''''''''''''''''''''''


'''''''''''''''''''''''''''''''''''''''''''''
End With

This line, how should it be?
This:

If Columns(h).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row > 6 Then

or that:

If .Columns(h).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row > 6 Then

???

 

[Akuini]

The second one.
But you also need to add dot on every range, cells, rows, etc.

.Range("R5") = "SysScore: " & SysScore

va = .Range("C7", .Cells(.Rows.Count, "C").End(xlUp))

va = .Cells(6 + a1, h).Resize(a2)

.Cells(6 + a1, h + 14).Resize(UBound(vc, 1), 1) = vc

 

[kelly mort]

I was able to fix those ones - the column thing was confusing me.

There is one more thing:
The ranking for column N.

When SysScore = "100 90", the rank for that column reserves 1000 for 1st, 900 for 2nd.

In the previous code you did some multiplication by 10 and I want to achieve same results.

I have 896 in my data as the largest number which should have ranked 3rd but it's ranking first.

 

[Akuini]

The ranking for column N.

When SysScore = "100 90", the rank for that column reserves 1000 for 1st, 900 for 2nd.

In the previous code you did some multiplication by 10 and I want to achieve same results.

I have 896 in my data as the largest number which should have ranked 3rd but it's ranking first.

Try this one:

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
   
With Sheets("Data")
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 h <> 14 Then
                            If Not scA.contains(CDbl(x)) Then
                                scA.Add CDbl(x)
                            End If
                        Else
                            x = x * 10 'for col N multiply SysScore by 10
                            If Not scA.contains(CDbl(x)) Then
                                scA.Add CDbl(x)
                            End If
                        End If
                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

End With
    Application.ScreenUpdating = True
End Sub

 

[kelly mort]

All is cool now.
Have a wonderful time.
I really appreciate what you have done for me.

Until I get further challenges, catch some rest.

 

[Akuini]

Ok, glad it works.

 

[Akuini]

@kelly mort
I forgot to tell you something.
I assumed that in your actual data your category (in your example X,Y,Z) doesn't have ":" (colon character ) in it. If it is not the case than we need to change the code a bit

 

[kelly mort]

Oh okay - thanks for the concern.

I don't have colon in the categories.