Set Lists

MrExcel · May 12, 2003

This is being posted on behalf of user Beaumont:

There must be a way to do this. I have a list of 350 students in sets called x1,x2..x7 and y1,y2..y7. Their names are in column A, sets in B and scores in C. I want Excel to take this info, without having to sort it, and give me fourteen rank ordered lists, one for each set, with scores in the left column and names in the right. These could begin in say cell e2 & f2 then a narrow one column gap to h2 and i2 or something.

This would be a great start. Even better would be if we could show how far ahead each student is ahead of the last, e.g if top student in x1 is 5% ahead of next student then this next student should appear 5 cells further down etc.

Best of all would be if we could do a quick visual comparison of the fourteen resultant lists (or perhaps the seven x sets, then the seven y sets) so that we can immediately see if anyone needs to be moved between groups.

Finally I would like someone to bring peace to the Middle East, land a human on Mars and enable my football team to win all their games next season.

Seriously I would appreciate any help you can give as I've been wrestling with this for years and have only achieved partial solutions. I could discuss these with you but don't want to prejudice any solutions you come up with.

Peter Beaumont

Mark O'Brien · May 12, 2003

Is a VBA solution acceptable?
Why not allow a sort?

The Mars and Middle East things might be possible, but it really depends what your team is.

NateO · May 12, 2003

Howdy, let's see if this maxes out the character limit.

Sub Sort_by_Grp()
' Kudos to John Walkenbach & J.G. Hussey related to Coll. Sort Technique _
 http://j-walk.com/ss/excel/tips/tip47.htm
Dim cl As Range, cls As Range, ws As Worksheet
Dim i As Integer, j As Integer
Dim Swap1, Swap2

Dim x1 As Collection, x2 As Collection, x3 As Collection, x4 As Collection
Dim x5 As Collection, x6 As Collection, x7 As Collection
Dim y1 As Collection, y2 As Collection, y3 As Collection, y4 As Collection
Dim y5 As Collection, y6 As Collection, y7 As Collection

Set x1 = New Collection: Set x2 = New Collection: Set x3 = New Collection
Set x4 = New Collection: Set x5 = New Collection: Set x6 = New Collection
Set x7 = New Collection
Set y1 = New Collection: Set y2 = New Collection: Set y3 = New Collection
Set y4 = New Collection: Set y5 = New Collection: Set y6 = New Collection
Set y7 = New Collection

Set cls = Sheets(1).[a1:a350]

For Each cl In cls
 Select Case cl(, 2).Value
 Case Is = "x1"
 x1.Add Array(cl(, 3), cl)
 Case Is = "x2"
 x2.Add Array(cl(, 3), cl)
 Case Is = "x3"
 x3.Add Array(cl(, 3), cl)
 Case Is = "x4"
 x4.Add Array(cl(, 3), cl)
 Case Is = "x5"
 x5.Add Array(cl(, 3), cl)
 Case Is = "x6"
 x6.Add Array(cl(, 3), cl)
 Case Is = "x7"
 x7.Add Array(cl(, 3), cl)
 Case Is = "y1"
 y1.Add Array(cl(, 3), cl)
 Case Is = "y2"
 y2.Add Array(cl(, 3), cl)
 Case Is = "y3"
 y3.Add Array(cl(, 3), cl)
 Case Is = "y4"
 y4.Add Array(cl(, 3), cl)
 Case Is = "y5"
 y5.Add Array(cl(, 3), cl)
 Case Is = "y6"
 y6.Add Array(cl(, 3), cl)
 Case Is = "y7"
 y7.Add Array(cl(, 3), cl)
 End Select
Next
Set cls = Nothing

For i = 1 To x1.Count - 1
 For j = i + 1 To x1.Count
 If x1(i)(0) < x1(j)(0) Then
 Swap1 = x1(i)
 Swap2 = x1(j)
 x1.Add Swap1, before:=j
 x1.Add Swap2, before:=i
 x1.Remove i + 1
 x1.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x2.Count - 1
 For j = i + 1 To x2.Count
 If x2(i)(0) < x2(j)(0) Then
 Swap1 = x2(i)
 Swap2 = x2(j)
 x2.Add Swap1, before:=j
 x2.Add Swap2, before:=i
 x2.Remove i + 1
 x2.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x3.Count - 1
 For j = i + 1 To x3.Count
 If x3(i)(0) < x3(j)(0) Then
 Swap1 = x3(i)
 Swap2 = x3(j)
 x3.Add Swap1, before:=j
 x3.Add Swap2, before:=i
 x3.Remove i + 1
 x3.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x4.Count - 1
 For j = i + 1 To x4.Count
 If x4(i)(0) < x4(j)(0) Then
 Swap1 = x4(i)
 Swap2 = x4(j)
 x4.Add Swap1, before:=j
 x4.Add Swap2, before:=i
 x4.Remove i + 1
 x4.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x5.Count - 1
 For j = i + 1 To x5.Count
 If x5(i)(0) < x5(j)(0) Then
 Swap1 = x5(i)
 Swap2 = x5(j)
 x5.Add Swap1, before:=j
 x5.Add Swap2, before:=i
 x5.Remove i + 1
 x5.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x6.Count - 1
 For j = i + 1 To x6.Count
 If x6(i)(0) < x6(j)(0) Then
 Swap1 = x6(i)
 Swap2 = x6(j)
 x6.Add Swap1, before:=j
 x6.Add Swap2, before:=i
 x6.Remove i + 1
 x6.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x7.Count - 1
 For j = i + 1 To x7.Count
 If x7(i)(0) < x7(j)(0) Then
 Swap1 = x7(i)
 Swap2 = x7(j)
 x7.Add Swap1, before:=j
 x7.Add Swap2, before:=i
 x7.Remove i + 1
 x7.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y1.Count - 1
 For j = i + 1 To y1.Count
 If y1(i)(0) < y1(j)(0) Then
 Swap1 = y1(i)
 Swap2 = y1(j)
 y1.Add Swap1, before:=j
 y1.Add Swap2, before:=i
 y1.Remove i + 1
 y1.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y2.Count - 1
 For j = i + 1 To y2.Count
 If y2(i)(0) < y2(j)(0) Then
 Swap1 = y2(i)
 Swap2 = y2(j)
 y2.Add Swap1, before:=j
 y2.Add Swap2, before:=i
 y2.Remove i + 1
 y2.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y3.Count - 1
 For j = i + 1 To y3.Count
 If y3(i)(0) < y3(j)(0) Then
 Swap1 = y3(i)
 Swap2 = y3(j)
 y3.Add Swap1, before:=j
 y3.Add Swap2, before:=i
 y3.Remove i + 1
 y3.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y4.Count - 1
 For j = i + 1 To y4.Count
 If y4(i)(0) < y4(j)(0) Then
 Swap1 = y4(i)
 Swap2 = y4(j)
 y4.Add Swap1, before:=j
 y4.Add Swap2, before:=i
 y4.Remove i + 1
 y4.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y5.Count - 1
 For j = i + 1 To y5.Count
 If y5(i)(0) < y5(j)(0) Then
 Swap1 = y5(i)
 Swap2 = y5(j)
 y5.Add Swap1, before:=j
 y5.Add Swap2, before:=i
 y5.Remove i + 1
 y5.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y6.Count - 1
 For j = i + 1 To y6.Count
 If y6(i)(0) < y6(j)(0) Then
 Swap1 = y6(i)
 Swap2 = y6(j)
 y6.Add Swap1, before:=j
 y6.Add Swap2, before:=i
 y6.Remove i + 1
 y6.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y7.Count - 1
 For j = i + 1 To y7.Count
 If y7(i)(0) < y7(j)(0) Then
 Swap1 = y7(i)
 Swap2 = y7(j)
 y7.Add Swap1, before:=j
 y7.Add Swap2, before:=i
 y7.Remove i + 1
 y7.Remove j + 1
 End If
 Next j
Next i

Application.ScreenUpdating = False

Set ws = Sheets(2)
ws.[e:h].ClearContents
With ws.[e1:h1]
 .Value = [{"Group","Score","","Name"}]
 .HorizontalAlignment = xlCenter
 .Font.Bold = True
End With

For i = 1 To x1.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x1"
 cl = x1(i)(0): cl(, 3) = x1(i)(1)
Next

For i = 1 To x2.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x2"
 cl = x2(i)(0): cl(, 3) = x2(i)(1)
Next

For i = 1 To x3.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x3"
 cl = x3(i)(0): cl(, 3) = x3(i)(1)
Next

For i = 1 To x4.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x4"
 cl = x4(i)(0): cl(, 3) = x4(i)(1)
Next

For i = 1 To x5.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x5"
 cl = x5(i)(0): cl(, 3) = x5(i)(1)
Next

For i = 1 To x6.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x6"
 cl = x6(i)(0): cl(, 3) = x6(i)(1)
Next

For i = 1 To x7.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x7"
 cl = x7(i)(0): cl(, 3) = x7(i)(1)
Next

For i = 1 To y1.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y1"
 cl = y1(i)(0): cl(, 3) = y1(i)(1)
Next

For i = 1 To y2.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y2"
 cl = y2(i)(0): cl(, 3) = y2(i)(1)
Next

For i = 1 To y3.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y3"
 cl = y3(i)(0): cl(, 3) = y3(i)(1)
Next

For i = 1 To y4.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y4"
 cl = y4(i)(0): cl(, 3) = y4(i)(1)
Next

For i = 1 To y5.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y5"
 cl = y5(i)(0): cl(, 3) = y5(i)(1)
Next

For i = 1 To y6.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y6"
 cl = y6(i)(0): cl(, 3) = y6(i)(1)
Next

For i = 1 To y7.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y7"
 cl = y7(i)(0): cl(, 3) = y7(i)(1)
Next
Set cl = Nothing
ws.Columns("G:G").ColumnWidth = 3.29
Set ws = Nothing

Application.ScreenUpdating = True

Set x1 = Nothing: Set x2 = Nothing: Set x3 = Nothing: Set x4 = Nothing
Set x5 = Nothing: Set x6 = Nothing: Set x7 = Nothing: Set y1 = Nothing
Set y2 = Nothing: Set y3 = Nothing: Set y4 = Nothing: Set y5 = Nothing
Set y6 = Nothing: Set y7 = Nothing
End Sub


Good, it didn't. Assumed data in sheets(1) [a1:c150]. Stacked 14 collections, sorted them. Slammed the results into sheets(2) [e2:g351] with headers. At this point you can work with individual collections.

Hope a vba approach is okay.

Might not be the best method, but it seemed to work on my spot checking. Didn't follow:

Best of all would be if we could do a quick visual comparison of the fourteen resultant lists (or perhaps the seven x sets, then the seven y sets) so that we can immediately see if anyone needs to be moved between groups.

Some sort of deviation calc. from the overall mean perhaps? Different means/outliers per group? Should be fairly doable at this point.

In any case, hope this helps.

just_jon · May 12, 2003

Nice code, Nate! If you turn it sideways, it looks *just* like my last EKG.

tusharm · May 12, 2003

Don't know why Nate suggested a VBA solution. From the problem description, and with the exception of some formatting requirements, I believe a PivotTable should do the job.

And, I guess the comment about visual comparison of the sets is in the same league as winning teams, since if we could get XL to understand sight...

MrExcel said:
This is being posted on behalf of user Beaumont:

There must be a way to do this. I have a list of 350 students in sets called x1,x2..x7 and y1,y2..y7. Their names are in column A, sets in B and scores in C. I want Excel to take this info, without having to sort it, and give me fourteen rank ordered lists, one for each set, with scores in the left column and names in the right. These could begin in say cell e2 & f2 then a narrow one column gap to h2 and i2 or something.

This would be a great start. Even better would be if we could show how far ahead each student is ahead of the last, e.g if top student in x1 is 5% ahead of next student then this next student should appear 5 cells further down etc.

Best of all would be if we could do a quick visual comparison of the fourteen resultant lists (or perhaps the seven x sets, then the seven y sets) so that we can immediately see if anyone needs to be moved between groups.

Finally I would like someone to bring peace to the Middle East, land a human on Mars and enable my football team to win all their games next season.

Seriously I would appreciate any help you can give as I've been wrestling with this for years and have only achieved partial solutions. I could discuss these with you but don't want to prejudice any solutions you come up with.

Peter Beaumont

Beaumont · May 13, 2003

I reckon I can manage the visual comparison bit myself.

Thank you for all your help. I have been unable to post from my home computer. I hope this one will work.

I am willing to use a VBA solution if necessary (did you really write all that code in such a short time?!) but I am unlikely to be able to adapt it to other slightly different situations. The code written seemed to do the first part of the task very well.

I am intrigued by the pivot table solution and would like to hear more.

Thanks again
Pete

NateO · May 13, 2003

Hello again,

Tusharm said:
Don't know why Nate suggested a VBA solution.

I know, it's only vba, but I like it.

Seriously, it's effective, meaning accurate and returns the data in a flexible/preferred format (with the right code modifications) and won't alter your file size to much extent. Very functional, not too slow, seems very viable to me.

Beaumont said:
I am willing to use a VBA solution if necessary (did you really write all that code in such a short time?!) but I am unlikely to be able to adapt it to other slightly different situations. The code written seemed to do the first part of the task very well.

Nope, I used the recorder.

Well, keep this is as a last resort.

I guess one man's trash is another man's treasure... To each their reach.

Yeah, I missed the other part, and rereading it, I realize that I don't understand this:

This would be a great start. Even better would be if we could show how far ahead each student is ahead of the last, e.g if top student in x1 is 5% ahead of next student then this next student should appear 5 cells further down etc.

I've adjusted the code to populate column I with the percentage of each students score above that of the lowest scoring student in the group. The spacing thing threw me off, why would you want to correlate a percentage difference with actual cell spacing? In any case, here's the tweak:

Sub Sort_by_Grp2()
' Kudos to John Walkenbach & J.G. Hussey from Coll. Sort Technique _
 http://j-walk.com/ss/excel/tips/tip47.htm
Dim cl As Range, cls As Range, ws As Worksheet
Dim i As Integer, j As Integer
Dim Swap1, Swap2

Dim x1 As Collection, x2 As Collection, x3 As Collection, x4 As Collection
Dim x5 As Collection, x6 As Collection, x7 As Collection
Dim y1 As Collection, y2 As Collection, y3 As Collection, y4 As Collection
Dim y5 As Collection, y6 As Collection, y7 As Collection

Set x1 = New Collection: Set x2 = New Collection: Set x3 = New Collection
Set x4 = New Collection: Set x5 = New Collection: Set x6 = New Collection
Set x7 = New Collection
Set y1 = New Collection: Set y2 = New Collection: Set y3 = New Collection
Set y4 = New Collection: Set y5 = New Collection: Set y6 = New Collection
Set y7 = New Collection
'****************************
Set cls = Sheets(1).[a1:a350] 'Set Your Input Range
'****************************
For Each cl In cls
 Select Case cl(, 2).Value
 Case Is = "x1"
 x1.Add Array(cl(, 3), cl)
 Case Is = "x2"
 x2.Add Array(cl(, 3), cl)
 Case Is = "x3"
 x3.Add Array(cl(, 3), cl)
 Case Is = "x4"
 x4.Add Array(cl(, 3), cl)
 Case Is = "x5"
 x5.Add Array(cl(, 3), cl)
 Case Is = "x6"
 x6.Add Array(cl(, 3), cl)
 Case Is = "x7"
 x7.Add Array(cl(, 3), cl)
 Case Is = "y1"
 y1.Add Array(cl(, 3), cl)
 Case Is = "y2"
 y2.Add Array(cl(, 3), cl)
 Case Is = "y3"
 y3.Add Array(cl(, 3), cl)
 Case Is = "y4"
 y4.Add Array(cl(, 3), cl)
 Case Is = "y5"
 y5.Add Array(cl(, 3), cl)
 Case Is = "y6"
 y6.Add Array(cl(, 3), cl)
 Case Is = "y7"
 y7.Add Array(cl(, 3), cl)
 End Select
Next
Set cls = Nothing

For i = 1 To x1.Count - 1
 For j = i + 1 To x1.Count
 If x1(i)(0) < x1(j)(0) Then
 Swap1 = x1(i)
 Swap2 = x1(j)
 x1.Add Swap1, before:=j
 x1.Add Swap2, before:=i
 x1.Remove i + 1
 x1.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x2.Count - 1
 For j = i + 1 To x2.Count
 If x2(i)(0) < x2(j)(0) Then
 Swap1 = x2(i)
 Swap2 = x2(j)
 x2.Add Swap1, before:=j
 x2.Add Swap2, before:=i
 x2.Remove i + 1
 x2.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x3.Count - 1
 For j = i + 1 To x3.Count
 If x3(i)(0) < x3(j)(0) Then
 Swap1 = x3(i)
 Swap2 = x3(j)
 x3.Add Swap1, before:=j
 x3.Add Swap2, before:=i
 x3.Remove i + 1
 x3.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x4.Count - 1
 For j = i + 1 To x4.Count
 If x4(i)(0) < x4(j)(0) Then
 Swap1 = x4(i)
 Swap2 = x4(j)
 x4.Add Swap1, before:=j
 x4.Add Swap2, before:=i
 x4.Remove i + 1
 x4.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x5.Count - 1
 For j = i + 1 To x5.Count
 If x5(i)(0) < x5(j)(0) Then
 Swap1 = x5(i)
 Swap2 = x5(j)
 x5.Add Swap1, before:=j
 x5.Add Swap2, before:=i
 x5.Remove i + 1
 x5.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x6.Count - 1
 For j = i + 1 To x6.Count
 If x6(i)(0) < x6(j)(0) Then
 Swap1 = x6(i)
 Swap2 = x6(j)
 x6.Add Swap1, before:=j
 x6.Add Swap2, before:=i
 x6.Remove i + 1
 x6.Remove j + 1
 End If
 Next j
Next i

For i = 1 To x7.Count - 1
 For j = i + 1 To x7.Count
 If x7(i)(0) < x7(j)(0) Then
 Swap1 = x7(i)
 Swap2 = x7(j)
 x7.Add Swap1, before:=j
 x7.Add Swap2, before:=i
 x7.Remove i + 1
 x7.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y1.Count - 1
 For j = i + 1 To y1.Count
 If y1(i)(0) < y1(j)(0) Then
 Swap1 = y1(i)
 Swap2 = y1(j)
 y1.Add Swap1, before:=j
 y1.Add Swap2, before:=i
 y1.Remove i + 1
 y1.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y2.Count - 1
 For j = i + 1 To y2.Count
 If y2(i)(0) < y2(j)(0) Then
 Swap1 = y2(i)
 Swap2 = y2(j)
 y2.Add Swap1, before:=j
 y2.Add Swap2, before:=i
 y2.Remove i + 1
 y2.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y3.Count - 1
 For j = i + 1 To y3.Count
 If y3(i)(0) < y3(j)(0) Then
 Swap1 = y3(i)
 Swap2 = y3(j)
 y3.Add Swap1, before:=j
 y3.Add Swap2, before:=i
 y3.Remove i + 1
 y3.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y4.Count - 1
 For j = i + 1 To y4.Count
 If y4(i)(0) < y4(j)(0) Then
 Swap1 = y4(i)
 Swap2 = y4(j)
 y4.Add Swap1, before:=j
 y4.Add Swap2, before:=i
 y4.Remove i + 1
 y4.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y5.Count - 1
 For j = i + 1 To y5.Count
 If y5(i)(0) < y5(j)(0) Then
 Swap1 = y5(i)
 Swap2 = y5(j)
 y5.Add Swap1, before:=j
 y5.Add Swap2, before:=i
 y5.Remove i + 1
 y5.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y6.Count - 1
 For j = i + 1 To y6.Count
 If y6(i)(0) < y6(j)(0) Then
 Swap1 = y6(i)
 Swap2 = y6(j)
 y6.Add Swap1, before:=j
 y6.Add Swap2, before:=i
 y6.Remove i + 1
 y6.Remove j + 1
 End If
 Next j
Next i

For i = 1 To y7.Count - 1
 For j = i + 1 To y7.Count
 If y7(i)(0) < y7(j)(0) Then
 Swap1 = y7(i)
 Swap2 = y7(j)
 y7.Add Swap1, before:=j
 y7.Add Swap2, before:=i
 y7.Remove i + 1
 y7.Remove j + 1
 End If
 Next j
Next i

Application.ScreenUpdating = False

Set ws = Sheets(2)
ws.[e:i].ClearContents
With ws.[e1:i1]
 .Value = [{"Group","Score","","Name","% Above Last"}] 'Set Your Headers
 .HorizontalAlignment = xlCenter
 .Font.Bold = True
End With

For i = 1 To x1.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x1" 'Pabel group on first
 cl = x1(i)(0): cl(, 3) = x1(i)(1) 'Plant Score & Name
 cl(, 4) = x1(i)(0) / x1(x1.Count)(0) - 1 'Plant % Above Last
Next

For i = 1 To x2.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x2"
 cl = x2(i)(0): cl(, 3) = x2(i)(1)
 cl(, 4) = x2(i)(0) / x2(x2.Count)(0) - 1
Next

For i = 1 To x3.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x3"
 cl = x3(i)(0): cl(, 3) = x3(i)(1)
 cl(, 4) = x3(i)(0) / x3(x3.Count)(0) - 1
Next

For i = 1 To x4.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x4"
 cl = x4(i)(0): cl(, 3) = x4(i)(1)
 cl(, 4) = x4(i)(0) / x4(x4.Count)(0) - 1
Next

For i = 1 To x5.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x5"
 cl = x5(i)(0): cl(, 3) = x5(i)(1)
 cl(, 4) = x5(i)(0) / x5(x5.Count)(0) - 1
Next

For i = 1 To x6.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x6"
 cl = x6(i)(0): cl(, 3) = x6(i)(1)
 cl(, 4) = x6(i)(0) / x6(x6.Count)(0) - 1
Next

For i = 1 To x7.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "x7"
 cl = x7(i)(0): cl(, 3) = x7(i)(1)
 cl(, 4) = x7(i)(0) / x7(x7.Count)(0) - 1
Next

For i = 1 To y1.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y1"
 cl = y1(i)(0): cl(, 3) = y1(i)(1)
 cl(, 4) = y1(i)(0) / y1(y1.Count)(0) - 1
Next

For i = 1 To y2.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y2"
 cl = y2(i)(0): cl(, 3) = y2(i)(1)
 cl(, 4) = y2(i)(0) / y2(y2.Count)(0) - 1
Next

For i = 1 To y3.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y3"
 cl = y3(i)(0): cl(, 3) = y3(i)(1)
 cl(, 4) = y3(i)(0) / y3(y3.Count)(0) - 1
Next

For i = 1 To y4.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y4"
 cl = y4(i)(0): cl(, 3) = y4(i)(1)
 cl(, 4) = y4(i)(0) / y4(y4.Count)(0) - 1
Next

For i = 1 To y5.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y5"
 cl = y5(i)(0): cl(, 3) = y5(i)(1)
 cl(, 4) = y5(i)(0) / y5(y5.Count)(0) - 1
Next

For i = 1 To y6.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y6"
 cl = y6(i)(0): cl(, 3) = y6(i)(1)
 cl(, 4) = y6(i)(0) / y6(y6.Count)(0) - 1
Next

For i = 1 To y7.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = "y7"
 cl = y7(i)(0): cl(, 3) = y7(i)(1)
 cl(, 4) = y7(i)(0) / y7(y7.Count)(0) - 1
Next
ws.Range([i2], cl(, 4)).NumberFormat = "0.00%"
Set cl = Nothing
ws.[g:g].ColumnWidth = 3
ws.[e:f,h:i].EntireColumn.AutoFit
Set ws = Nothing

Application.ScreenUpdating = True

Set x1 = Nothing: Set x2 = Nothing: Set x3 = Nothing: Set x4 = Nothing
Set x5 = Nothing: Set x6 = Nothing: Set x7 = Nothing: Set y1 = Nothing
Set y2 = Nothing: Set y3 = Nothing: Set y4 = Nothing: Set y5 = Nothing
Set y6 = Nothing: Set y7 = Nothing
End Sub

This code is relatively flexible, you can change length of the list, vary group sizes, memborships and it should still fire. Have a good one eh.

tusharm · May 13, 2003

{shrug} Never did like reinventing the wheel, Nate. Da Vinci's take on simplicity and sophistication has had a major impact on my thinking for a rather long time.

NateO said:
Hello again,

Tusharm said:

Don't know why Nate suggested a VBA solution.

Click to expand...

I know, it's only vba, but I like it. Seriously, it's effective, meaning accurate and returns the data in a flexible/preferred format (with the right code modifications) and won't alter your file size to much extent. Very functional, not too slow, seems very viable to me.

lenze · May 13, 2003

Although the code posted is interesting, I agree with Tusharm. This problem is being over complicated. A well designed PIVOT TABLE should yield the correct results

NateO · May 13, 2003

lenze said:
Although the code posted is interesting,

Glad that you think so, a lot of people would not find this to be the case. More importantly, in my opinion, it's a relevant functioning solution to the problem.

I agree with Tusharm.

Polls are typically conducted in the lounge.

This problem is being over complicated.

I agree. The complicated solution is matching the complications created by, as Mark was alluding to, confusing constraints. In which Excel version can someone not sort data? Turns out I also think the P.T. is overkill here as well. Here's another solution (which violates a constraint):

Copy the data to a new worksheet. Paste it in column a:c. Sort the data, Sort group in ascending order and score in descending. Now run some straight-forward worksheet functions through column d. Done.

A well designed PIVOT TABLE should yield the correct results

Fair enough. Peter has already stated interest in your alluded-to solution AND that he does not know how to set it up. Why not be a sport and help him out (versus responding to me (I already have a sufficient handle on the situation))? There's no need for me solve this a third or fourth way.

For all you KISS fans, stop reading here. I've streamlined the code above in terms of length:

Sub Sort_by_Grp3()
' Kudos to John Walkenbach & J.G. Hussey from Coll. Sort Technique _
 http://j-walk.com/ss/excel/tips/tip47.htm
Dim cl As Range, cls As Range, ws As Worksheet
Dim i As Integer, j As Integer
Dim Swap1, Swap2
Dim MyCol As Collection, Cnt As Collection
Set MyCol = New Collection: Set Cnt = New Collection
'****************************
Set cls = Sheets(1).[a1:a350] 'Set Your Input Range
'****************************
For Each cl In cls
 MyCol.Add Array(cl(, 3), cl, cl(, 2))
Next
Set cls = Nothing

For i = 1 To MyCol.Count - 1
 For j = i + 1 To MyCol.Count
 If MyCol(i)(2) > MyCol(j)(2) Then
 Swap1 = MyCol(i)
 Swap2 = MyCol(j)
 MyCol.Add Swap1, before:=j
 MyCol.Add Swap2, before:=i
 MyCol.Remove i + 1
 MyCol.Remove j + 1
 End If
 Next j
Next i

For i = 1 To MyCol.Count - 1
 For j = i + 1 To MyCol.Count
 If MyCol(i)(0) < MyCol(j)(0) And _
 MyCol(i)(2) = MyCol(j)(2) Then
 Swap1 = MyCol(i)
 Swap2 = MyCol(j)
 MyCol.Add Swap1, before:=j
 MyCol.Add Swap2, before:=i
 MyCol.Remove i + 1
 MyCol.Remove j + 1
 End If
 Next j
Next i

Application.ScreenUpdating = False

Set ws = Sheets(2)
ws.[e:i].ClearContents
With ws.[e1:i1]
 .Value = [{"Group","Score","","Name","% Above Last"}] 'Set Your Headers
 .HorizontalAlignment = xlCenter
 .Font.Bold = True
End With

For i = 1 To MyCol.Count
 Set cl = ws.[f65536].End(3)(2)
 If i = 1 Then cl(, 0) = MyCol(i)(2) 'Pabel group on first
 On Error GoTo 1
 If MyCol(i)(2) <> MyCol(i - 1)(2) Then
 cl(, 0) = MyCol(i)(2)
 Cnt.Add cl.Row
 End If
1: On Error GoTo 0
 cl = MyCol(i)(0): cl(, 3) = MyCol(i)(1) 'Plant Score & Name
Next
Set MyCol = Nothing

For i = 1 To Cnt.Count
 With ws.Range(ws.[i65536].End(3)(2), ws.Cells(Cnt(i) - 1, 9))
 .Formula = "=RC[-3]/R" & Cnt(i) - 1 & "C6-1"
 .Value = .Value
 End With
Next

With ws.Range(ws.[i65536].End(3)(2), ws.[h65536].End(3).Item(, 2))
 .Formula = "=RC[-3]/R" & ws.[h65536].End(3).Row & "C6-1"
 .Value = .Value
End With
Set Cnt = Nothing

ws.Range([i2], cl(, 4)).NumberFormat = "0.00%"
Set cl = Nothing
ws.[g:g].ColumnWidth = 3
ws.[e:f,h:i].EntireColumn.AutoFit
Set ws = Nothing
Application.ScreenUpdating = True

End Sub

But not in process time, much slower than the last posted proc. Think the 3-d items/sorting on this collection is bogging it down a touch.

Set Lists

MrExcel

.

Excel Facts

Mark O'Brien

MrExcel MVP

NateO

Legend

just_jon

Legend

tusharm

MrExcel MVP

Beaumont

New Member

NateO

Legend

tusharm

MrExcel MVP

lenze

Legend

NateO

Legend

Similar threads

Forum statistics

Share this page

Set Lists

.

Excel Facts

MrExcel MVP

Legend

Legend

MrExcel MVP

New Member

Legend

MrExcel MVP

Legend

Legend

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock