Ranking Code Amendment With System Reserved Numbers -vba

Status
Not open for further replies.

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. Windows
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 the top-most ranks, should those numbers fail to appear in my data as I define the rules below. So these are the rules:
1. 100 is always ranked first. Which means that if there is no 100 in my data, then the highest number in my data is second but not first and run for numbers from 99 to 95 in my data
2. If there are no numbers from 99 to 95 in my data, then 95 is ranked second into the system, then numbers from 94 to 91 take from 4th downwards. But if there are say 98 and 96 in my data, then after systematically using the first rank for 100(system number), then we have 2nd for 98 and 3rd for 96. In this case, the next system number, 95, which by default was supposed to be 2nd, will now shift to the 4th rank. So here, the rank shift as there are more numbers in between.
3. If the highest ranked number in the point 2 above is 2nd, then, we assign 3rd to our system number 90. But if that is different, say 3rd, 4th etc, then we make the rank shift as described in point 2 above.


Sample of how I want my output look like
Code:
==================
Number        Rank
==================
98        2nd
96        3nd
94        5th
93        6th
70        8th 
=================
From the above, since there were no 100, 95 and 90 in my data, those ranks were absorbed by the system, 1st for 100, 4th for 95 and 7th for 90.


Thanks so much for your time and effort to help me out.


Code:
Sub RankDynamic()
     Dim dicSection As Object, vItem As Variant, wsData As Worksheet, vSection As Variant, rScore As Range, _
     rCell As Range, Score As Variant, Rnk As Double, LastRow&, iCol&
     Application.ScreenUpdating = False
     
     Set wsData = Sheets("Sheet1")
    With wsData
        If .FilterMode Then .ShowAllData
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
     End With
     
    If LastRow > 1 Then
         'Data exists
    Else
        MsgBox "No data exists!", vbExclamation
        Exit Sub
    End If
    
    On Error Resume Next
    Set dicSection = CreateObject("Scripting.Dictionary")
    dicSection.CompareMode = 1 'vbTextCompare
    vSection = wsData.Range("C6:C" & LastRow).Value
    For i = LBound(vSection) + 1 To UBound(vSection)
        If Not dicSection.Exists(vSection(i, 1)) Then
            dicSection(vSection(i, 1)) = ""
        End If
     Next i
For Each vItem In dicSection.keys()
    With wsData.UsedRange
    .AutoFilter field:=3, Criteria1:=vItem
    
    Set rScore = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
    For i = 2 To 12
        For Each rCell In rScore.Offset(, i)
        Score = rCell.Value
            If Application.IsNumber(Score) Then
                Rnk = WorksheetFunction.Rank(CDbl(Score), rScore.Offset(, i))
                rCell.Offset(, 12).Value = Rnk & GetOrdinalSuffixForRank(Rnk)
            End If
        Next rCell
    Next i
        .AutoFilter
    End With
    Next vItem
    Application.ScreenUpdating = True
    
    Set dicSection = Nothing
    Set rScore = Nothing
    Set rCell = Nothing
End Sub


Function GetOrdinalSuffixForRank(Rnk As Double) 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
     GetOrdinalSuffixForRank = sSuffix
End Function
 
Yes!!!!

You did it again :bow::bow:

You have really opened my eyes to what VBA can do.
 
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Hi, @Akuini and anyone who can help me out with this.
I am looking for a way to switch the arr variable dynamically.
So since we are ranking the items dynamically using the categories under column C, I need a way to be able to switch the arr content by determining the row with maximum filled cells in a given category. So there are a total of eleven cells in each row, from the data we are analyzing. Then, it is possible that not all the 11 cells in a row will be filled. So with each category, I want to know maximum filled cells in a column; is it 11, 10, 9, 8, etc. So based on that maximum number of filled cells as defined above, I decide which value to assign to the arr variable.

If it is 11 then ary = Split(“1100 1045 990”)
If it is 10 then ary = Split(“1000 950 900”)
If it is 9 then ary = Split(“900 855 810”)
If it is 8 then ary = Split(“800 760 640”)

In this manner as above. I will be very glad to have a fix for this. Thanks in advance

This part of the code is where I need the modification for
Code:
                    ary = Split(“1000 950 900”)
                    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, 15, 15, ary)
 
Upvote 0
Can you post an example? so I can understand it better.
FYI, the best way to post a range/table is by using XL2BB add-in, you can download it by clicking the XL2BB icon in the reply window.
 
Upvote 0
LAYOUT_FOR_AKUINI.jpg

What I have here is an image display. I used a count function under column Q to find the none blank cells.
So since we have three categories so far, the ary variable get switched three times:
One for the X category, where the Max filled cells in a row was 10

So we use
ary = Split(“1000 950 900”)

The next for the Y category, and the time, ary is still same since from the post, the max filled cells is 10
ary = Split(“1000 950 900”)

Then finally, for Z category, max filled cells is 11
If it is 11 then ary = Split(“1100 1045 990”)


I hope this is very clear. Have a nice time
 
Upvote 0
Try this:
Rich (BB code):
Sub Kelly1()
Dim d As Object
Dim m As Long, qr As Long, qq As Long
Dim ary
Dim hh As Long, xq As Long, xz As Long

Application.ScreenUpdating = False
qq = Range("C" & Rows.count).End(xlUp).Row   'I changed this from col  D to C, because in your new data set col D could have blank.
Range("P" & 7 & ":Y" & qq).ClearContents
For qr = 7 To qq
    
    m = WorksheetFunction.CountIf(Range("C7:C" & qq), Range("C" & qr))  'case insensitive
 
    
        ary = Split("100 95 90")
        ary = Application.Transpose(Application.Transpose(ary))
        'ary = Application.Transpose(Range("O2", Cells(Rows.Count, "O").End(xlUp)))
        
        Set d = CreateObject("scripting.dictionary")
            For i = 1 To UBound(ary)
                d(CLng(ary(i))) = Empty
            Next
        Call toRank(qr, m, d, 4, 13, ary)
        
    hh = 0
    For xq = qr To qr + m - 1
        xz = WorksheetFunction.CountA(Range("D" & xq & ":" & "N" & xq))
        If xz > hh Then hh = xz
    Next
    
        Select Case hh
            
            Case 11
            ary = Split("1100 1045 990")
            Case 10
            ary = Split("1000 950 900")
            Case 9
            ary = Split("900 855 810")
            Case 8
            ary = Split("800 760 640")

        End Select
        
        'ary = Split("1000 950 900")
        ary = Application.Transpose(Application.Transpose(ary))
        'ary = Application.Transpose(Range("AA2", Cells(Rows.Count, "AA").End(xlUp)))
        
        Set d = CreateObject("scripting.dictionary")
            For i = 1 To UBound(ary)
                d(CLng(ary(i))) = Empty
            Next
        Call toRank(qr, m, d, 14, 14, ary)

    qr = qr + m - 1

Next qr

Application.ScreenUpdating = True

End Sub

1. You've changed the data layout? in your old data layout, the data is in col C:M, now is in col C:N?
2. What should happen if maximum filled cells is below 8?
 
Upvote 0
Solution
Hi @Akuini,

It worked brilliantly.

To answer your questions, question 1 is yes; I did change the layout.

Then for question 2, I will continue the case statement till 1.

This is how I was trying to achieve that;

Code:
sp  = Split("100 95 90")
Select Case hh
   Case 11
       For i  = 0 To Ubound(sp)
          sp(i) =sp(i)*11
      Next 
    MyVar = Join(sp, " ")
    ary  = Split(MyVar)
Case 10
................
End Select

So I have completed the above lines to take care of the switch.

It seems a bit long ATM. But I have no idea if there is a shorter way to get it done.
 
Upvote 0
I don't understand the pattern. Can you show us the complete code?
Code:
sp = Split("100 95 90")
        Select Case hh
            Case 11
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 11
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 10
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 10
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 9
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 9
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 8
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 8
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 7
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 7
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 6
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 6
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 5
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 5
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 4
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 4
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 3
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 3
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 2
                For i = 0 To UBound(sp)
                    sp(i) = sp(i) * 2
                Next i
                MyVar = Join(sp, " ")
                ary = Split(MyVar)
            Case 1
                ary = sp
        End Select
 
Upvote 0
You can replace your code above with this one line:
ary = Split(100 * hh & " " & 95 * hh & " " & 90 * hh)
 
Upvote 0
You can replace your code above with this one line:
ary = Split(100 * hh & " " & 95 * hh & " " & 90 * hh)

Lol
So all those lines to just this line!!!

Indeed, there is always a better way.

Now, from the code you supplied me here:

I am assigning the ary to the txt variable.

Which means that it won't be static as the above. So in that case how do I get the right switch ?
 
Upvote 0
Status
Not open for further replies.

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top