Automate Schedule Assignment

[jjtok7]

Trying to figure out a way to automate the process of assigning schedule to participants. The participant selects all the schedule they are interested/wiling to work. Then I assign schedules based off of rank (high-low). Each participant can be assigned one schedule and each schedule can be assigned once. Let me know if this is possible

AssignedSchdeules_Temp.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Names	Rank	Assigned Scheudle	Schedule Interest 1	Schedule Interest 2	Schedule Interest 3	Schedule Interest 4	Schedule Interest 5	Schedule Interest 6	Schedule Interest 7	Schedule Interest 8	Schedule Interest 9	Schedule Interest 10
2	Person 19	1		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
3	Person 16	2		Schedule 1	Schedule 2	Schedule 4	Schedule 3	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
4	Person 33	3		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
5	Person 35	4		Schedule 18	Schedule 26
6	Person 2	5		Schedule 1	Schedule 2	Schedule 18	Schedule 3
7	Person 26	6		Schedule 13	Schedule 14	Schedule 18	Schedule 26
8	Person 31	7		Schedule 18	Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9
9	Person 34	8		Schedule 18	Schedule 1
10	Person 13	9		Schedule 13	Schedule 14
11	Person 14	10		Schedule 1	Schedule 14
12	Person 7	11		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
13	Person 15	14		Schedule 13	Schedule 15	Schedule 26	Schedule 11
14	Person 20	19		Schedule 13	Schedule 14	Schedule 15	Schedule 16	Schedule 18	Schedule 19	Schedule 20	Schedule 21	Schedule 26	Schedule 12
15	Person 18	22		Schedule 18
16	Person 1	23		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
17	Person 6	27		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
18	Person 28	28		Schedule 19	Schedule 20	Schedule 21	Schedule 22	Schedule 23	Schedule 24	Schedule 27	Schedule 28	Schedule 29	Schedule 30
19	Person 41	33		Schedule 11	Schedule 10	Schedule 9	Schedule 8	Schedule 7	Schedule 6	Schedule 5	Schedule 4	Schedule 3	Schedule 2
20	Person 4	34		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
21	Person 5	35		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
22	Person 9	37		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
23	Person 37	38		Schedule 18	Schedule 26	Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8
24	Person 11	40		Schedule 11	Schedule 10	Schedule 13
25	Person 32	41		Schedule 18	Schedule 39	Schedule 40	Schedule 41	Schedule 42
26	Person 8	42		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
27	Person 40	44		Schedule 18	Schedule 26
28	Person 24	46		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
29	Person 23	48		Schedule 1	Schedule 12	Schedule 11	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8
30	Person 27	51		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
31	Person 29	58		Schedule 12	Schedule 25	Schedule 31
32	Person 25	59		Schedule 25	Schedule 24	Schedule 23	Schedule 22	Schedule 21	Schedule 20	Schedule 19	Schedule 18	Schedule 17	Schedule 16
33	Person 30	60		Schedule 37	Schedule 36	Schedule 38	Schedule 34	Schedule 35	Schedule 32	Schedule 33
34	Person 39	61		Schedule 4	Schedule 11	Schedule 13
35	Person 12	62		Schedule 3	Schedule 4	Schedule 2	Schedule 1	Schedule 5	Schedule 12	Schedule 11	Schedule 7	Schedule 6	Schedule 8
36	Person 10	63		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
37	Person 36	64		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
38	Person 17	67		Schedule 13	Schedule 14	Schedule 15	Schedule 16	Schedule 17	Schedule 18	Schedule 19	Schedule 20	Schedule 21	Schedule 26
39	Person 38	68		Schedule 1	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6	Schedule 7	Schedule 8	Schedule 9	Schedule 10
40	Person 22	72		Schedule 1	Schedule 11	Schedule 12	Schedule 13	Schedule 15	Schedule 19	Schedule 22
41	Person 3	77		Schedule 1	Schedule 2	Schedule 3
42	Person 21	12		Schedule 1	Schedule 12	Schedule 14	Schedule 18	Schedule 26	Schedule 2	Schedule 3	Schedule 4	Schedule 5	Schedule 6
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C2:C42	Cell Value	duplicates	text	NO
C2:C42	Cell Value	duplicates	text	NO
A2:A42	Cell Value	duplicates	text	NO
D33:M33	Cell Value	duplicates	text	NO

 

[BSALV]

How do you want this ?
1. Start with the person with the lowest rank and go from left to right until he/she has a schedule and then go down
or
2. start also with the person of the lowest rank and go from top to bottom so try to give everybody his first choise and the next column, etc
???

method 2
jjtok7

Sub Scheduling()
     Set dict = CreateObject("scripting.dictionary")
     dict.comparemode = vbTextCompare

     Set lo = Sheets("Blad1").ListObjects(1)     'that table
     lo.ListColumns(3).DataBodyRange.ClearContents     'clear the assigned schedule column
     arr = lo.DataBodyRange.Value     'data >>> array
     col1 = lo.DataBodyRange.Columns(1) 'column1 = persons
     arr1 = Application.Sort(arr, 2)     'sort on the rank (2nd column)

     For j = 4 To UBound(arr, 2)     'loop through the interests
          For i = 1 To UBound(arr)     'loop throught the persons
               If Len(arr1(i, 3)) = 0 Then     'person doesn't have an assignment yet
                    If Not dict.exists(arr1(i, j)) Then     'schedule isn't assigned neither
                         arr1(i, 3) = arr1(i, j)
                         dict(arr1(i, j)) = vbEmpty
                         r = Application.Match(arr1(i, 1), col1, 0)     'original line number
                         If IsNumeric(r) Then arr(r, 3) = arr1(i, j)
                    End If
               End If
          Next
     Next

     lo.ListColumns(3).DataBodyRange.Value = Application.Index(arr, 0, 3)
     
     
     lo.Range.Offset(10 + lo.ListRows.Count).Resize(UBound(arr1), UBound(arr1, 2)).Value = arr1

End Sub

 

[jjtok7]

How do you want this ?
1. Start with the person with the lowest rank and go from left to right until he/she has a schedule and then go down
or
2. start also with the person of the lowest rank and go from top to bottom so try to give everybody his first choise and the next column, etc
???

method 2
jjtok7

Sub Scheduling()
     Set dict = CreateObject("scripting.dictionary")
     dict.comparemode = vbTextCompare

     Set lo = Sheets("Blad1").ListObjects(1)     'that table
     lo.ListColumns(3).DataBodyRange.ClearContents     'clear the assigned schedule column
     arr = lo.DataBodyRange.Value     'data >>> array
     col1 = lo.DataBodyRange.Columns(1) 'column1 = persons
     arr1 = Application.Sort(arr, 2)     'sort on the rank (2nd column)

     For j = 4 To UBound(arr, 2)     'loop through the interests
          For i = 1 To UBound(arr)     'loop throught the persons
               If Len(arr1(i, 3)) = 0 Then     'person doesn't have an assignment yet
                    If Not dict.exists(arr1(i, j)) Then     'schedule isn't assigned neither
                         arr1(i, 3) = arr1(i, j)
                         dict(arr1(i, j)) = vbEmpty
                         r = Application.Match(arr1(i, 1), col1, 0)     'original line number
                         If IsNumeric(r) Then arr(r, 3) = arr1(i, j)
                    End If
               End If
          Next
     Next

     lo.ListColumns(3).DataBodyRange.Value = Application.Index(arr, 0, 3)
    
    
     lo.Range.Offset(10 + lo.ListRows.Count).Resize(UBound(arr1), UBound(arr1, 2)).Value = arr1

End Sub

Thanks for the reply!
I definitely like this method but I think method 1 is more of what I'm looking for. I would like to make sure people with the lowest rankings (1,2,3,...) get assigned a schedule first.

 

[BSALV]

that was an easy one, just swap the 2 For's !
jjtok7
You noticed perhaps that the copy further down is a sorted copy on the 2nd column (rank)