Allocation of people to their choices

[Ker28]

Hi,

I have a project which requires me to allocate people to their choices. However, each choice has different limits. I do not have any background in using VBA hence I have almost nothing to start with.


Each student has 3 choices (A, B and C) which they can rank as first, second and third. I have a total of 20 people at hand. However, there's a limit of 6 people for Choice A, 5 people for Choice B and 5 people for Choice C. That leaves 4 people who do not get their choices at the end. I have split Choice A, Choice B, Choice C and No Choice into 4 different sheets.


I would like to ask if anyone knows how to create a VBA code such that everyone's choices are sorted in the table in List of Students (Sheet 1), then they are allocated to their first choices as much as possible.


The case should go like this: If a person has Choice A as 1st choice, Choice B as 2nd choice, Choice C as 3rd choice: Check if Choice A still has vacancy, if vacancy>0, person is inserted into Choice A sheet. If vacancy=0, check Choice B sheet instead. In choice B sheet, if vacancy >0, person is inserted into Choice B sheet. And so on.


I actually have a list of more than a few hundred people in my project, with a bigger limit for each choice. So I have simplified it to this example instead. Here's my simplified excel sheet: https://www.dropbox.com/s/rgje2hs0kqehe5s/Allocation%20of%20students%20to%20choices.xlsx?dl=0



Appreciate all help! Thank you in advance!

 

[konew1]

If I was one of your students I would like my name checked first, so I would always get my first choice. For fairness you need to randomize the sequence. Sorry, but I can't help with a solution for you.

 

[Snakehips]

Ker28,

Welcome to MrExcel.

Re kone1's valid point, I see from your file that you intend the list of names to be in random order.

In order to set choice limits that can be readily accessed by the code, I would suggest you enter as per e.g. Cells I:1:I3

Excel 2007
	A	B	C	D	E	F	G	H	I
1	No.	Random Names	Membership No.	1st Choice	2nd Choice	3rd choice		Places A	6
2	1	Jina Cheeks	#001	A	B	C		Places B	5
3	2	Adelaide Railey	#002	A	B	C		Places C	5
4	3	Kristin Breazeale	#003	A	C	B		No Choice	4
5	4	Ruben Seel	#004	A	B	C
List of people

Cell Formulas
Range	Formula
I4	=MAX(A:A)-SUM(I1:I3)

Then hopefully the below code will select as you would wish...

Sub Allocate()
'Selection limits
La = Range("I1")
Lb = Range("I2")
Lc = Range("I3")
'Last row
lr = Cells(Rows.Count, 2).End(xlUp).Row
For r = 2 To lr  'loop through names
    For col = 4 To 6  'step through Choices columns as required
        Select Case Cells(r, col) 'deal with choice
            Case "A"
                If Ca < La Then  'count less than limit so available
                Ca = Ca + 1  'increment count for A
                Cx = Ca  'set count to use
                Lx = La  'set limit to use
                Else
                GoTo Nxt  'otherwise no availability try next choice
                End If
            Case "B"
                If Cb < Lb Then
                Cb = Cb + 1
                Cx = Cb
                Lx = Lb
                Else
                GoTo Nxt
                End If
            Case "C"
                If Cc < Lc Then
                Cc = Cc + 1
                Cx = Cc
                Lx = Lc
                Else
                GoTo Nxt
                End If
            Case Else
            End Select
        
            If Cx > Lx Then  '? no vacancy for choice
                Exit For  'if no vacancy quit loop
                Else  'pass detail to sheet of choice
                Sheets("Choice " & Cells(r, col)).Cells(Cx + 1, 2) = Cells(r, 2)
                Sheets("Choice " & Cells(r, col)).Cells(Cx + 1, 3) = Cells(r, 3)
                Exit For
            End If
Nxt:
        If col = 6 Then    ' If choice column = 6 then no availability at all
        ' so put to No Choice sheet
            Cn = Cn + 1
            Sheets("Not given any choices").Cells(Cn + 1, 2) = Cells(r, 2)
            Sheets("Not given any choices").Cells(Cn + 1, 3) = Cells(r, 3)
        End If
    Next col  ' next choice column


Next r  'next name
End Sub

Hope that helps.

 

[Paperlurve]

Hi!

http://www.dropbox.com/s/wyu797p4q289pvc/Sample%20for%20allocating%20students.xlsm?dl=0


I happened to come across this thread and it was exactly what I was looking for. So I tried out the method with my data, however I receive the "Subscript out of range" error message. Have no experience with VBA coding as well and would appreciate if you could shed some light on this.

I have 3 timeslots option
1) 3.30pm-6.30pm (Tues)
2) 7pm-10pm (Wed)
3) 3.30pm-6.30pm (Thurs)

And I would like to allocate the students to their preferred timeslots into one sheet, the "allocated slot" sheet.

Attached above is my sample, hope to receive your reply soon.


Thankyou!

Cheers!

 

[Snakehips]

Paperlurve,

Welcome to MrExcel.

The code needs several modifications to work with your setup.

You do not have three independent allocation sheets as per the original poster and none of the 3 coded 'Choice' names match your Allocation sheet name.
You are wanting to send the allocations to one of three different ranges within one allocation sheet.
You have more header rows than the OP.

Thus you will need the code modified as below.

I suggest also that you copy the code to the 'List Of People' sheet module rather than the Worksheet module. (Right click sheet tab >>> View Code >> Paste into code pane)

Sub Allocate()
'Selection limits
La = Range("I1")
Lb = Range("I2")
Lc = Range("I3")
'Last row
lr = Cells(Rows.Count, 2).End(xlUp).Row
For r = 2 To lr  'loop through names
    For col = 4 To 6  'step through Choices columns as required
        Select Case Cells(r, col) 'deal with choice
            Case "3.30pm-6.30pm (Tues)"
                If Ca < La Then  'count less than limit so available
                Ca = Ca + 1    'increment count for A
                Cx = Ca  'set count to use
                Lx = La  'set limit to use
                ColOset = 0  'Offset in Allocated sheet to give B & C
                Else
                GoTo Nxt  'otherwise no availability try next choice
                End If
            Case "7pm-10pm (Wed)"
                If Cb < Lb Then
                Cb = Cb + 1
                Cx = Cb
                Lx = Lb
                ColOset = 5  'Offset in Allocated sheet to give columns G & H
                Else
                GoTo Nxt
                End If
            Case "3.30pm-6.30pm (Thurs)"
                If Cc < Lc Then
                Cc = Cc + 1
                Cx = Cc
                Lx = Lc
                ColOset = 10  'Offset in Allocated sheet to give columns L & M
                Else
                GoTo Nxt
                End If
            Case Else
            End Select
        
            If Cx > Lx Then  '? no vacancy for choice
                Exit For  'if no vacancy quit loop
                Else  'pass to Allocated Slot sheet
                Sheets("Allocated Slot").Cells(Cx + 3, 2 + ColOset) = Cells(r, 2)
                Sheets("Allocated Slot").Cells(Cx + 3, 3 + ColOset) = Cells(r, 3)
                Sheets("Allocated Slot").Cells(Cx + 3, 4 + ColOset) = Cells(r, col)
                Exit For
            End If
Nxt:
        If col = 6 Then    ' If choice column = 6 then no availability at all
        ' so put to No Choice sheet
            Cn = Cn + 1
            Sheets("Not given any choices").Cells(Cn + 1, 2) = Cells(r, 2)
            Sheets("Not given any choices").Cells(Cn + 1, 3) = Cells(r, 3)
            Sheets("Not given any choices").Cells(Cn + 1, 4) = "None"
        End If
    Next col  ' next choice column




Next r  'next name
End Sub

Hope that helps.

 

[shg]

How about just a formula?

Row\Col	A​	B​	C​	D​	E​	F​	G​	H​	I​	J​
1​
2​			​	Max​	Act​
3​			A​	6​	6​					D3:D5: Input
4​			B​	5​	5​					E3 and down: =COUNTIF($H$8:$H$27, C3)
5​			C​	5​	5​
6​
7​	#​	Name​	ID​	1st​	2nd​	3rd​		Assign​	Choice​
8​	1​	Alan		A​	B​	C​		A​	1​	H8 and down: {=INDEX(D8:F8, MATCH(TRUE, COUNTIF(H$7:H7, D8:F8) < LOOKUP(D8:F8, $C$3:$D$5), 0))}
9​	2​	Barb		A​	B​	C​		A​	1​
10​	3​	Cain		C​	A​	B​		C​	1​
11​	4​	Dana		A​	B​	C​		A​	1​
12​	5​	Eric		B​	C​	A​		B​	1​
13​	6​	Fran		C​	B​	A​		C​	1​
14​	7​	Gary		A​	C​	B​		A​	1​
15​	8​	Hana		A​	B​	C​		A​	1​
16​	9​	Ivan		A​	B​	C​		A​	1​
17​	10​	Jane		B​	C​	A​		B​	1​
18​	11​	Kent		B​	A​	C​		B​	1​
19​	12​	Leah		B​	A​	C​		B​	1​
20​	13​	Mark		C​	B​	A​		C​	1​
21​	14​	Nina		C​	A​	B​		C​	1​
22​	15​	Otto		C​	A​	B​		C​	1​
23​	16​	Peri		A​	B​	C​		B​	2​
24​	17​	Quin		A​	C​	B​		#N/A​	#N/A​
25​	18​	Rene		A​	C​	B​		#N/A​	#N/A​
26​	19​	Seth		A​	B​	C​		#N/A​	#N/A​
27​	20​	Tina		B​	C​	A​		#N/A​	#N/A​

 

[Ker28]

Hi Tony,

Thank you so much for your help. It works perfectly! This forum is amazing.

Cheers

 

[phok84]

Hi All,

I love this solution, but I'm trying to make it work for 9 "slots" instead of the three used in OP's example. How would I update the VBA code to make this work? I basically updated the OP's excel file to add 6 additional choices and ranges in the allocation sheet.

I tried this:

Sub Allocate()'Selection limits
La = Range("I1")
Lb = Range("I2")
Lc = Range("I3")
Ld = Range("I4")
Le = Range("I5")
Lf = Range("I6")
Lg = Range("I7")
Lh = Range("I8")
Li = Range("I9")
'Last row
lr = Cells(Rows.Count, 2).End(xlUp).Row
For r = 2 To lr  'loop through names
    For col = 4 To 6  'step through Choices columns as required
        Select Case Cells(r, col) 'deal with choice
            Case "Endocrine Systems"
                If Ca < La Then  'count less than limit so available
                Ca = Ca + 1    'increment count for A
                Cx = Ca  'set count to use
                Lx = La  'set limit to use
                ColOset = 0  'Offset in Allocated sheet to give B & C
                Else
                GoTo Nxt  'otherwise no availability try next choice
                End If
            Case "Sex Differences in Development"
                If Ca < La Then  'count less than limit so available
                Cb = Cb + 1    'increment count for A
                Cx = Cb  'set count to use
                Lx = Lb  'set limit to use
                ColOset = 5  'Offset in Allocated sheet to give B & C
                Else
                GoTo Nxt  'otherwise no availability try next choice
                End If
            Case "Sex Differences in Behaviour"
                If Cc < Lc Then
                Cc = Cc + 1
                Cx = Cc
                Lx = Lc
                ColOset = 10  'Offset in Allocated sheet to give columns L & M
                Else
                GoTo Nxt
                End If
            Case "Parental Behaviours"
                If Cd < Ld Then
                Cd = Cd + 1
                Cx = Cd
                Lx = Ld
                Col0set = 15
                Else
                GoTo Nxt
                End If
            Case "Social Behaviours"
                If Ce < Le Then
                Ce = Ce + 1
                Cx = Ce
                Lx = Le
                Col0set = 20
                Else
                GoTo Nxt
                End If
            Case "Homeostasis & Behaviour"
                If Cf < Lf Then
                Cf = Cf + 1
                Cx = Cf
                Lx = Lf
                Col0set = 25
                Else
                GoTo Nxt
                End If
            Case "Stress I"
                If Cg < Lg Then
                Cg = Cg + 1
                Cx = Cg
                Lx = Lg
                Col0set = 30
                Else
                GoTo Nxt
                End If
            Case "Stress II"
                If Ch < Lh Then
                Ch = Ch + 1
                Cx = Ch
                Lx = Lh
                Col0set = 35
                Else
                GoTo Nxt
                End If
            Case "Developmental Origins of Health & Disease (DOHaD)"
                If Ci < Li Then
                Ci = Ci + 1
                Cx = Ci
                Lx = Li
                Col0set = 40
                Else
                GoTo Nxt
                End If
            Case Else
            End Select
        
            If Cx > Lx Then  '? no vacancy for choice
                Exit For  'if no vacancy quit loop
                Else  'pass to Allocated Slot sheet
                Sheets("Allocated Slot").Cells(Cx + 3, 2 + ColOset) = Cells(r, 2)
                Sheets("Allocated Slot").Cells(Cx + 3, 3 + ColOset) = Cells(r, 3)
                Sheets("Allocated Slot").Cells(Cx + 3, 4 + ColOset) = Cells(r, 4)
                Sheets("Allocated Slot").Cells(Cx + 3, 5 + Col0set) = Cells(r, 5)
                Sheets("Allocated Slot").Cells(Cx + 3, 6 + Col0set) = Cells(r, 6)
                Sheets("Allocated Slot").Cells(Cx + 3, 7 + Col0set) = Cells(r, 7)
                Sheets("Allocated Slot").Cells(Cx + 3, 8 + Col0set) = Cells(r, 8)
                Sheets("Allocated Slot").Cells(Cx + 3, 9 + ColOset) = Cells(r, col)
                Exit For
            End If
Nxt:
        If col = 6 Then    ' If choice column = 6 then no availability at all
        ' so put to No Choice sheet
            Cn = Cn + 1
            Sheets("Not given any choices").Cells(Cn + 1, 2) = Cells(r, 2)
            Sheets("Not given any choices").Cells(Cn + 1, 3) = Cells(r, 3)
            Sheets("Not given any choices").Cells(Cn + 1, 4) = "None"
        End If
    Next col  ' next choice column








Next r  'next name
End Sub

Thank you so much!

 

[drhitesh2002]

H8 and down: {=INDEX(D8:F8, MATCH(TRUE, COUNTIF(H$7:H7, D8:F8) < LOOKUP(D8:F8, $C$3:$D$5), 0))}

Please help me

I am pasting this formula in cell.

But not working,.

Please help me quickly...

 

[drhitesh2002]

H8 and down: {=INDEX(D8:F8, MATCH(TRUE, COUNTIF(H$7:H7, D8:F8) < LOOKUP(D8:F8, $C$3:$D$5), 0))}

I am not able to do this formula...

Please help me...