x
Solved

# ranking using multiple criteria

Posted on 2011-03-13
Medium Priority
352 Views
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

0
Question by:pwflexner
• 2

LVL 30

Accepted Solution

SiddharthRout earned 500 total points
ID: 35122291
Here is one way to do it. Run the macro "Sample" and the data will be auto populated in cells C5:G5

Sid

Code Used

``````Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long

Application.ScreenUpdating = False

Set ws1 = ActiveSheet

ws1.Range("A2:E2").Copy
ws2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True

ws1.Range("G1:K1").Copy
ws2.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True

ws1.Range("A1:E1").Copy
ws2.Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True

ws2.Sort.SortFields.Clear
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ws2.Sort
.SetRange ws2.Range("A1:C5")
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
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

ws2.Range("C1:C5").Copy
ws1.Range("C5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True

ws2.Delete
Application.ScreenUpdating = True
End Sub
``````
sort-results.xlsm
0

Author Comment

ID: 35122410
Thanks!! This is great.
0

LVL 30

Expert Comment

ID: 35122414

Sid
0

## Featured Post

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.