ranking using multiple criteria

I'm trying to rank five objects, call them objects a, b, c, d and e.  Each object has two "scores". Cells a1, b1, c1, d1 and e1 hold one set of scores for objects a, b, c, d and e respectively.  These scores are either an H (for 'high'), an M (for 'medium') or an L (for 'low').  Cells g1, h1, i1, j1 and k1 held the second set of scores.  These are numbers, with a higher number being a better score.  There are multiple sets of object, ie multiple rows of data.

I'll rank the objects on the first set of scores (columns a thru e).  All objects with an H get the highest rank, and among those, the objects should be ranked according to the second set of scores.  Then, all objects with an M are ranked according to their second set of scores, and finally the Ls are ranked according to their scores.  For example,

The objects are: a, b, c, d, e
The first set of scores are: M, H, M, L, H
The second set of scores are: 64, 57, 73, 62, 71

The ranking should be: e, b, c, a, d

Thanks for your help...
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

SiddharthRoutConnect With a Mentor Commented:
Here is one way to do it. Run the macro "Sample" and the data will be auto populated in cells C5:G5


Code Used

Sub Sample()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, j As Long
    Application.ScreenUpdating = False
    Set ws1 = ActiveSheet
    Set ws2 = Sheets.Add
    ws2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=True
    ws2.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=True
    ws2.Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=True
    ws2.Sort.SortFields.Add Key:=ws2.Range("A1:A5"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws2.Sort.SortFields.Add Key:=ws2.Range("B1:B5"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ws2.Sort
        .SetRange ws2.Range("A1:C5")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
    End With
    j = 10
    For i = 5 To 1 Step -1
        If UCase(ws2.Range("A" & i).Value) = "L" Then
            ws2.Range("A" & i & ":C" & i).Cut ws2.Range("A" & j & ":C" & j)
            j = j - 1
        End If
    Next i
    ws2.Cells.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    ws1.Range("C5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=True
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Open in new window

pwflexnerAuthor Commented:
Thanks!! This is great.
Glad you like it :)

All Courses

From novice to tech pro — start learning today.