Help require to modify rank formula for subject groups

[mso3]

Hi friends,
There are groups of subjects in column ‘I’. I want to give rank as per the subject group in column ‘n’.

The problem is that there are two groups for English ‘english1 and english2’ and for Hindi ‘hindi1 and hindi2’. I want to treat these groups as one and rank according to it.

English1 and English2 one subject group
Hindi1 and Hindi2 one subject group

Please see the attachment and suggest me amendment in the rank formula in column ‘N’.

Any help will be appreciated.

Thanking you.

[Ace_XL]

In N4 try

=IF(OR(I4="",M4=""),"",1+SUMPRODUCT((LEFT($I$4:$I$20,LEN($I$4:$I$20)-1)=LEFT(I4,LEN(I4)-1))*($M$4:$M$20>M4)))

Your ranges should be restricted to non-blank cells only

[mso3]

Hi Ace_XL,
Thank you. It's working fine for restricted ranges only. The ranges are not fixed. It varies time to time as per the divisions in the standard and subjects. So I don't want any restriction in ranges. Whether it is blank of nonblank the formula should work.

Please do the amendment to remove the restriction of ranges.

Thank you.

[samba_ravi]

is it ok to insert one more column for subject

Subject Subject type
english1 english
english1 english
english1 english
english2 english
english2 english
english2 english
hindi1 hindi
Hindi1 Hindi
hindi2 hindi
Hindi2 Hindi
marathi marathi
marathi marathi
marathi marathi
maths maths
maths maths
maths maths
maths maths

[mso3]

No, The data is retrieve from several result sheets automatically by a programme so it's not possible to insert a helping column.

I want amendment in this situation only to avoide any further complications in my main programme.

Thanking you.

[Ace_XL]

Try

=IF(OR(I4="",M4=""),"",1+SUMPRODUCT((LEFT($I$4:INDEX($I$4:$I$100,COUNTA($I$4:$I$100)),LEN($I$4:INDEX($I$4:$I$100,COUNTA($I$4:$I$100)))-1)=LEFT(I4,LEN(I4)-1))*($M$4:INDEX($M$4:$M$100,COUNTA($I$4:$I$100))>M4)))

[samba_ravi]

Try

=IF(OR(I4="",M4=""),"",1+SUMPRODUCT((LEFT($I$4:INDEX($I$4:$I$100,COUNTA($I$4:$I$100)),LEN($I$4:INDEX($I$4:$I$100,COUNTA($I$4:$I$100)))-1)=LEFT(I4,LEN(I4)-1))*($M$4:INDEX($M$4:$M$100,COUNTA($I$4:$I$100))>M4)))

@ Ace_XL
If subject entered like
maths1
maths1
maths
maths
then it will be problem

[mso3]

Hi ase_xl,
Ok! It's working fine but if there is a word instead of number 1, 2 then it's giving error. I have subjects like

subject
English general
English general
English general
English special
English special
English special

in my original workbook. In this case it's not working. As Siva stated it's also not working if there are more than 2 subjects having 1, 2 after subject name.

Mainly I have a problem of word after main subject like mentioned above. Please suggest me a correction to work the formula if there is a word after main subject.

Sorry for trouble.

Thank you.

[mso3]

Hi excel expert friends,

Bump!

Due to this problem my work is stopped so I humbly request you to look into this problem and suggest me a concrete solution to achieve the target of proper ranking as per my requirement. I'm quite optimistic to receive a solution today from you excel experts positively.

Waiting to receive a solution.

Thanking you.

[LJMetzger]

Hi,

Try the following macro which is implemented in the attached workbook:

Option Explicit

Sub CalculateRanks()
  'This calculates RANK as follows:
  'a. Gets the Subject from Column 'I' (removes any single DIGIT from the rear of the Subject) - case insensitive
  'b. Gets the Grade from Column 'M'
  'c. After reading all data, calculates the Ranks and puts the ranks in Column 'N'
  '
  'Data is sorted using a Shell Sort which should be a lot more robust than a Bubble Sort.

  Dim a() As String
  Dim i As Long
  Dim iCountThisSubject As Long
  Dim iLastRow As Long
  Dim iNumberOfLineItems As Long
  Dim iRank As Long
  Dim iRow As Long
  
  Dim bValidDataThisLine As Boolean
  
  Dim xGrade As Double
  
  Dim c As String
  Dim sGrade As String
  Dim sGradeOld As String
  Dim sRange As String
  Dim sSubject As String
  Dim sSubjectOld As String
  Dim sValue As String
  
  'Initialize the Dynamic String Array
  ReDim a(1 To 1)
  
  
  'Clear the result area - column 'N'
  sRange = "N4:N" & ActiveSheet.Rows.Count
  Range(sRange).ClearContents
  
  'Find the Last Row in Column 'I' (Subject) (if no data(runtime error) then the value is 0
  On Error Resume Next
  iLastRow = 0
  iLastRow = Range("I:I").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  On Error GoTo 0

  'Process all rows starting at row 4
  For iRow = 4 To iLastRow
  
    bValidDataThisLine = True
  
    'Get the Subject Name (DO NOT PROCESS IF BLANK) - case insensitive
    'Get the Grade (DO NOT PROCESS IF NOT A NUMBER)
    sSubject = UCase(Trim(Cells(iRow, "I").Value))
    sGrade = Cells(iRow, "M").Value
    
    'Remove the last character from the Subject if it is a Number
    'and do a coarse validity check
    If Len(sSubject) > 0 Then
      c = Right(sSubject, 1)
      If IsNumeric(c) Then
        sSubject = Left(sSubject, Len(sSubject) - 1)
      End If
    Else
      bValidDataThisLine = False
    End If
    If Len(sSubject) < 2 Then
      bValidDataThisLine = False
    End If
    
    'Convert the string grade into a number
    'Otherwise the grad is invalid
    If IsNumeric(sGrade) Then
      xGrade = CDbl(sGrade)
    Else
      bValidDataThisLine = False
    End If
    If xGrade < 0 Or xGrade > 2# Then
      bValidDataThisLine = False
    End If


    'Add the data to the 'String Concatenation Array' if the data is valid
    'Concatenation array is of the form 'sssssssssssssssssss x.xxxx~nnnn'
    'where 'ssss' is a 30 character blank padded string
    'where xxx.xxxx is the grade
    'where '~' is the 'Tilde' Character
    'where nnnn is the row number
    If bValidDataThisLine = True Then
      iNumberOfLineItems = iNumberOfLineItems + 1
      ReDim Preserve a(1 To iNumberOfLineItems)

      '                                          0        1         2         3
      '                                          123456789012345678901234567890
      a(iNumberOfLineItems) = Format(sSubject, "!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@") & _
                              Format(xGrade, "0.0000 ") & _
                              Format(iRow, "0000")
      Debug.Print a(iNumberOfLineItems)
    End If
  Next iRow

  'Sort the data in Descending Order
  Call LjmShellSortStringDescending(a)
  
  
  'Rank the data using the Sorted Values
  iCountThisSubject = 0
  For i = 1 To iNumberOfLineItems
    sValue = a(i)
    sSubject = Trim(Left(sValue, 30))
    
    sGrade = Mid(sValue, 31, 6)
    
    iRow = CLng(Right(sValue, 4))
    
    If sSubject = sSubjectOld Then
      iCountThisSubject = iCountThisSubject + 1
      If sGrade <> sGradeOld Then
        iRank = iCountThisSubject    'Otherwise the rank stays the same
      End If
    Else
      'New Subject
      iCountThisSubject = 1
      iRank = 1
    End If
    
    'Debug.Print iRow, sSubject, sGrade, iCountThisSubject, iRank
    
    'Save the current Subject and Grade for future use
    sSubjectOld = sSubject
    sGradeOld = sGrade
    
    'Put the data in the proper row
    Cells(iRow, "N") = iRank
  Next i
   

End Sub

Public Sub LjmShellSortStringDescending(ByRef sArray() As String)
  'This sorts a string array in descending order using a 'Shell Sort' algorithm

  Dim iHold As Integer
  Dim iGap As Integer
  Dim i As Integer
  Dim iMin As Integer
  Dim iMax As Integer
  Dim sSwap As String
       
  iMin = LBound(sArray)
  iMax = UBound(sArray)
  iGap = iMin
        
        
  Do
    iGap = 3 * iGap + 1
  Loop Until iGap > iMax
        
  Do
    iGap = iGap \ 3
    For i = iGap + iMin To iMax
      sSwap = sArray(i)
      iHold = i
                
      Do While sArray(iHold - iGap) < sSwap
        sArray(iHold) = sArray(iHold - iGap)
        iHold = iHold - iGap
        If iHold < iMin + iGap Then Exit Do
      Loop
      sArray(iHold) = sSwap
        
    Next i
      
  Loop Until iGap = 1
        
End Sub

[mso3]

Hi Lewis,
Excellent job done. Thank you. It's working fine but if there is any word after main subject then it gives wrong ranking. Please see the output column 'o'.

I have inserted a small code with a formula to achieve it suggested by Jbealcare which gives a correct output in rank.

Everything else is perfect.

I appreciate you for the efforts taken to create a such challenging macro to achieve the target of ranking.

Thanking you,

[LJMetzger]

It's working fine but if there is any word after main subject then it gives wrong ranking.

I beg to differ with that assessment. I believe it gives the correct ranking to your previous specification. It is very difficult to provide an answer to 'dynamic requirements.'

See the attached file and the following code (major changes in red) that I believe will solve your latest specification.

Lewis

Option Explicit

Sub CalculateRanks()
  'This calculates RANK as follows:
  'a. Gets the Subject from Column 'I' (removes any single DIGIT from the rear of the Subject) - case insensitive
  '   The subject is limited to the FIRST TOKEN (Anything after the first SPACE is NOT COUNTED in the Ranking)
  'b. Gets the Grade from Column 'M'
  'c. After reading all data, calculates the Ranks and puts the ranks in Column 'N'
  '
  'Data is sorted using a Shell Sort which should be a lot more robust than a Bubble Sort.

  Dim a() As String
  Dim b() As String
  Dim i As Long
  Dim iCountThisSubject As Long
  Dim iLastRow As Long
  Dim iNumberOfLineItems As Long
  Dim iRank As Long
  Dim iRow As Long
  
  Dim bValidDataThisLine As Boolean
  
  Dim xGrade As Double
  
  Dim c As String
  Dim sGrade As String
  Dim sGradeOld As String
  Dim sRange As String
  Dim sSubject As String
  Dim sSubjectOld As String
  Dim sValue As String
  
  'Initialize the Dynamic String Array
  ReDim a(1 To 1)
  
  
  'Clear the result area - column 'N'
  sRange = "N4:N" & ActiveSheet.Rows.Count
  Range(sRange).ClearContents
  
  'Find the Last Row in Column 'I' (Subject) (if no data(runtime error) then the value is 0
  On Error Resume Next
  iLastRow = 0
  iLastRow = Range("I:I").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  On Error GoTo 0

  'Process all rows starting at row 4
  For iRow = 4 To iLastRow
  
    bValidDataThisLine = True
  
    'Get the Subject Name (DO NOT PROCESS IF BLANK) - case insensitive
    'Get the Grade (DO NOT PROCESS IF NOT A NUMBER)
    sSubject = UCase(Trim(Cells(iRow, "I").Value))
    sGrade = Cells(iRow, "M").Value
    
    'Remove any text after the first SPACE in the Subject
    'Remove the last character from the Subject if it is a Number
    'and do a coarse validity check
    If Len(sSubject) > 0 Then
      'Parse the subject into tokens
      'Only use the first token
      Call LjmParseString(sSubject, b)
      sSubject = b(0)
      
      c = Right(sSubject, 1)
      If IsNumeric(c) Then
        sSubject = Left(sSubject, Len(sSubject) - 1)
      End If
    Else
      bValidDataThisLine = False
    End If
    If Len(sSubject) < 2 Then
      bValidDataThisLine = False
    End If
    
    'Convert the string grade into a number
    'Otherwise the grad is invalid
    If IsNumeric(sGrade) Then
      xGrade = CDbl(sGrade)
    Else
      bValidDataThisLine = False
    End If
    If xGrade < 0 Or xGrade > 2# Then
      bValidDataThisLine = False
    End If


    'Add the data to the 'String Concatenation Array' if the data is valid
    'Concatenation array is of the form 'sssssssssssssssssss x.xxxx~nnnn'
    'where 'ssss' is a 30 character blank padded string
    'where xxx.xxxx is the grade
    'where '~' is the 'Tilde' Character
    'where nnnn is the row number
    If bValidDataThisLine = True Then
      iNumberOfLineItems = iNumberOfLineItems + 1
      ReDim Preserve a(1 To iNumberOfLineItems)

      '                                          0        1         2         3
      '                                          123456789012345678901234567890
      a(iNumberOfLineItems) = Format(sSubject, "!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@") & _
                              Format(xGrade, "0.0000 ") & _
                              Format(iRow, "0000")
      Debug.Print a(iNumberOfLineItems)
    End If
  Next iRow

  'Sort the data in Descending Order
  Call LjmShellSortStringDescending(a)
  
  
  'Rank the data using the Sorted Values
  iCountThisSubject = 0
  For i = 1 To iNumberOfLineItems
    sValue = a(i)
    sSubject = Trim(Left(sValue, 30))
    
    sGrade = Mid(sValue, 31, 6)
    
    iRow = CLng(Right(sValue, 4))
    
    If sSubject = sSubjectOld Then
      iCountThisSubject = iCountThisSubject + 1
      If sGrade <> sGradeOld Then
        iRank = iCountThisSubject    'Otherwise the rank stays the same
      End If
    Else
      'New Subject
      iCountThisSubject = 1
      iRank = 1
    End If
    
    'Debug.Print iRow, sSubject, sGrade, iCountThisSubject, iRank
    
    'Save the current Subject and Grade for future use
    sSubjectOld = sSubject
    sGradeOld = sGrade
    
    'Put the data in the proper row
    Cells(iRow, "N") = iRank
  Next i
   

End Sub

Public Sub LjmShellSortStringDescending(ByRef sArray() As String)
  'This sorts a string array in descending order using a 'Shell Sort' algorithm

  Dim iHold As Integer
  Dim iGap As Integer
  Dim i As Integer
  Dim iMin As Integer
  Dim iMax As Integer
  Dim sSwap As String
       
  iMin = LBound(sArray)
  iMax = UBound(sArray)
  iGap = iMin
        
        
  Do
    iGap = 3 * iGap + 1
  Loop Until iGap > iMax
        
  Do
    iGap = iGap \ 3
    For i = iGap + iMin To iMax
      sSwap = sArray(i)
      iHold = i
                
      Do While sArray(iHold - iGap) < sSwap
        sArray(iHold) = sArray(iHold - iGap)
        iHold = iHold - iGap
        If iHold < iMin + iGap Then Exit Do
      Loop
      sArray(iHold) = sSwap
        
    Next i
      
  Loop Until iGap = 1
        
End Sub

Function LjmParseString(InputString As String, ByRef sArray() As String) As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This parses a space delimited string into an array of tokens.
' Leading and trailing spaces are stripped from the string in the process.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  Dim i As Integer
  Dim LastNonEmpty As Integer
  Dim iSplitIndex As Integer

 'Initialization
  LastNonEmpty = -1
  
  'Split the string into tokens
  sArray = Split(InputString)
  iSplitIndex = UBound(sArray)

 'Remove the null tokens
  For i = 0 To iSplitIndex

    If sArray(i) <> "" Then
       'Get rid of all the whitespace
        LastNonEmpty = LastNonEmpty + 1
        sArray(LastNonEmpty) = sArray(i)
    End If
  Next i


 'Return the number of indices
  LjmParseString = LastNonEmpty
  
End Function

[mso3]

Hi Lewis,
Excellent! Excellent! Excellent!

What a dynamic creation for a challenging dynamic ranking. I salute your knowledge of vba.

I appreciate you for the excellent creation to achieve the target.

Thank you.