Help creating simple model to allocate choices to maximize ranked preferences

A

antonware

New Member
Joined
Sep 23, 2015
Messages
3
Windows 7/ Excel 2010. I have 14 students in my seminar. I need to group the 14 students into 7 pairs, and each pair will be responsible for presenting on 1 of 7 topics. I've asked the students to rank the 7 topics in order of preference (1 being highest, 7 lowest). I would like to enter the preference data into a model/formula in Excel that will then tell me the allocation of topics to students that will maximize the preferences of the greatest number of students. If there is an existing tutorial or thread that provides an answer, I'd be grateful for any leads. I have only the most basic proficiency in Excel and thus will need a simple step-by-step explanation of how to build this model.

Thank you in advance for your assistance!

My data looks like this:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Student#[/TD]
[TD]Topic1[/TD]
[TD]Topic2[/TD]
[TD]Topic3[/TD]
[TD]Topic4[/TD]
[TD]Topic5[/TD]
[TD]Topic6[/TD]
[TD]Topic7[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]1[/TD]
[TD]5[/TD]
[TD]4[/TD]
[TD]7[/TD]
[TD]6[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]etc.[/TD]
[TD]etc.[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Sort by date Sort by votes
Really interesting question!

My first thought was to use the Solver, but coming up with an appropriate equation and constraints proved to be tougher than I originally thought.

My next thought was to try all combinations and look for the best result. This actually worked pretty well. If you have your table laid out as you showed it, with the rating for Student1, topic1 in B2 (2), then this program should work.

Press Alt-F11 to enter the VBA editor. In the navigation pane on the left, right-click on Microsoft Excel Objects, select Insert, Module. On the sheet that opens up, paste this:
Code: 
Public score As Double
Public groups As String
Public Const ShortWay = True


Sub temp1()
Dim prefs(14, 7)


    t = Timer
    For r = 1 To 14
        For c = 1 To 7
            prefs(r, c) = Cells(r + 1, c + 1)
        Next c
    Next r
    
   score = 9999999
   
   Call CalcIt("ABCDEFGHIJKLMN", "", "1234567", prefs, 0)
   
   Debug.Print score, groups, Timer - t
    
End Sub
Sub CalcIt(whosleft, assigned, topicsleft, ByRef prefs, curscore)


    On Error GoTo oops:
    DoEvents
    If Len(whosleft) = 0 Then
        If curscore < score Then
            score = curscore
            groups = assigned
        End If
        Exit Sub
    End If
    
    stud1l = Left(whosleft, 1)
    stud1 = Asc(stud1l) - 64
    
    For i = 2 To Len(whosleft)
        stud2l = Mid(whosleft, i, 1)
        stud2 = Asc(stud2l) - 64
        score1 = 15
        score1x = 0


    If ShortWay Then
        For j = 1 To Len(topicsleft)
            topic = Mid(topicsleft, j, 1)
            scorew = prefs(stud1, topic) + prefs(stud2, topic)
            If scorew < score1 Then
                score1 = scorew
                score1x = topic
            End If
        Next j
        score2 = curscore + score1
        topic = score1x
        l2 = Replace(Mid(whosleft, 2), stud2l, "")
        t2 = Replace(topicsleft, topic, "")
        a2 = assigned & stud1l & stud2l & topic & "."
        Call CalcIt(l2, a2, t2, prefs, score2)
    Else
        For j = 1 To Len(topicsleft)
            topic = Mid(topicsleft, j, 1)
            score2 = curscore + prefs(stud1, topic) + prefs(stud2, topic)
            l2 = Replace(Mid(whosleft, 2), stud2l, "")
            t2 = Replace(topicsleft, topic, "")
            a2 = assigned & stud1l & stud2l & topic & "."
            Call CalcIt(l2, a2, t2, prefs, score2)
        Next j
    End If
    
    Next i
    Exit Sub
oops:
    Debug.Print "Someone goofed on this program!"
    b = 1 / 0
    
End Sub
(For coding purists out there, I apologize! I'm in a hurry and don't have time to clean it up.)

Put the cursor in the temp1 sub, and press F5 to run it. It will take about 10 seconds and in the Immediate window will return something like:

17 AN3.BE1.CM7.DJ2.FH4.GI5.KL6. 6.738281

Student1=A, Student2=B, etc. The 17 is the overall score, the lower the better, 14 is perfect with everyone getting top choice. The string of letters next to it is the pairs. In this case Student A is paired with student N with topic 3, and so on. The last number is just the time it took to run.

(If you don't have an Immediate window, click on the View menu item and select it.)

What this does is take every possible pair of students, then pick the topic with the lowest combined score for those 2 students. Then pick another possible pair and repeat until everyone is chosen. Take the overall score and if it's better than the current best, save it.

If you don't get a really good score, you can change the line:

Public Const ShortWay = True

to

Public Const ShortWay = False

This will take MUCH longer (I don't know how long, I never let it finish), but will get the best possible score.

Good luck!
 
Upvote 0
Wow, thank you for taking the time to prepare this thorough answer. I will give it a try and let you know how it goes. Thanks!

Eric W said:
Really interesting question!

My first thought was to use the Solver, but coming up with an appropriate equation and constraints proved to be tougher than I originally thought.

My next thought was to try all combinations and look for the best result. This actually worked pretty well. If you have your table laid out as you showed it, with the rating for Student1, topic1 in B2 (2), then this program should work.

Press Alt-F11 to enter the VBA editor. In the navigation pane on the left, right-click on Microsoft Excel Objects, select Insert, Module. On the sheet that opens up, paste this:
Code: 
Public score As Double
Public groups As String
Public Const ShortWay = True


Sub temp1()
Dim prefs(14, 7)


    t = Timer
    For r = 1 To 14
        For c = 1 To 7
            prefs(r, c) = Cells(r + 1, c + 1)
        Next c
    Next r
    
   score = 9999999
   
   Call CalcIt("ABCDEFGHIJKLMN", "", "1234567", prefs, 0)
   
   Debug.Print score, groups, Timer - t
    
End Sub
Sub CalcIt(whosleft, assigned, topicsleft, ByRef prefs, curscore)


    On Error GoTo oops:
    DoEvents
    If Len(whosleft) = 0 Then
        If curscore < score Then
            score = curscore
            groups = assigned
        End If
        Exit Sub
    End If
    
    stud1l = Left(whosleft, 1)
    stud1 = Asc(stud1l) - 64
    
    For i = 2 To Len(whosleft)
        stud2l = Mid(whosleft, i, 1)
        stud2 = Asc(stud2l) - 64
        score1 = 15
        score1x = 0


    If ShortWay Then
        For j = 1 To Len(topicsleft)
            topic = Mid(topicsleft, j, 1)
            scorew = prefs(stud1, topic) + prefs(stud2, topic)
            If scorew < score1 Then
                score1 = scorew
                score1x = topic
            End If
        Next j
        score2 = curscore + score1
        topic = score1x
        l2 = Replace(Mid(whosleft, 2), stud2l, "")
        t2 = Replace(topicsleft, topic, "")
        a2 = assigned & stud1l & stud2l & topic & "."
        Call CalcIt(l2, a2, t2, prefs, score2)
    Else
        For j = 1 To Len(topicsleft)
            topic = Mid(topicsleft, j, 1)
            score2 = curscore + prefs(stud1, topic) + prefs(stud2, topic)
            l2 = Replace(Mid(whosleft, 2), stud2l, "")
            t2 = Replace(topicsleft, topic, "")
            a2 = assigned & stud1l & stud2l & topic & "."
            Call CalcIt(l2, a2, t2, prefs, score2)
        Next j
    End If
    
    Next i
    Exit Sub
oops:
    Debug.Print "Someone goofed on this program!"
    b = 1 / 0
    
End Sub
(For coding purists out there, I apologize! I'm in a hurry and don't have time to clean it up.)

Put the cursor in the temp1 sub, and press F5 to run it. It will take about 10 seconds and in the Immediate window will return something like:

17 AN3.BE1.CM7.DJ2.FH4.GI5.KL6. 6.738281

Student1=A, Student2=B, etc. The 17 is the overall score, the lower the better, 14 is perfect with everyone getting top choice. The string of letters next to it is the pairs. In this case Student A is paired with student N with topic 3, and so on. The last number is just the time it took to run.

(If you don't have an Immediate window, click on the View menu item and select it.)

What this does is take every possible pair of students, then pick the topic with the lowest combined score for those 2 students. Then pick another possible pair and repeat until everyone is chosen. Take the overall score and if it's better than the current best, save it.

If you don't get a really good score, you can change the line:

Public Const ShortWay = True

to

Public Const ShortWay = False

This will take MUCH longer (I don't know how long, I never let it finish), but will get the best possible score.

Good luck!
Click to expand...
 
Upvote 0
This appears to have worked well (I let it run overnight with the "False" code --- it ran for 16 hours but ultimately returned what appears to be an optimal score). Thanks again!
 
Upvote 0
16 hours, wow! I'm glad I didn't wait for it. I knew this was a "brute-force" type solution. I suspect that with a bit more analysis I could come up with a faster method. But since you got what you needed, I'll save that for another time. Thanks for the feedback.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Help creating model to allocate preferred choices but with limited no. of allocations per choice to maximize ranked preferences
Replies
3
Views
671
kevin9999
K
N
  • Question Question
Excel VBA for dynamic mean weighted ranking
Replies
0
Views
650
neroed
N

Share this page

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