randomly assign equal number of students to tutors

[adamelston]

Hello, I have a list of c300 student IDs and 13 tutors. Please could you tell me how to randomly assign an equal (as far as possible) number of student IDs to tutors? Many thanks, Adam

 

[Logit]

.

Option Explicit


Sub RotList2()
Application.ScreenUpdating = False
Range("A3:B302").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B3:B302") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:B302")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Sheet1").Range("A1").Select
Application.ScreenUpdating = True
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/2ZJCD3YmnwEHwZVIq7l3zPEiZDbXhHwvKlR6nwtVQia

 

[Rick Rothstein]

Here is another macro that you can consider. It assumes the student names are listed in Column A starting on Row 1 and that the tutor names are listed in Column B starting on Row 1... it output the randomized student names in their own cells starting at Column C on the same row with the tutor they are assigned to.

[table="width: 500"]
[tr]
	[td]Sub StudentTutorAssignments()
  Dim X As Long, Cnt As Long, RandomIndex As Long, Tmp As Variant, Tutors As Variant, Students As Variant
  Students = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  ReDim Tutors(0 To Cells(Rows.Count, "B").End(xlUp).Row - 1, 1 To 1)
  Randomize
  For Cnt = UBound(Students) To 1 Step -1
    RandomIndex = Int(Cnt * Rnd + 1)
    Tmp = Students(RandomIndex, 1)
    Students(RandomIndex, 1) = Students(Cnt, 1)
    X = (X + 1) Mod (UBound(Tutors) + 1)
    Tutors(X, 1) = Tutors(X, 1) & "," & Tmp
    If Left(Tutors(X, 1), 1) = "," Then Tutors(X, 1) = Mid(Tutors(X, 1), 2)
  Next
  Range("C1").Resize(UBound(Tutors) + 1) = Tutors
  Application.DisplayAlerts = False
  Columns("C").TextToColumns , xlDelimited, , , False, False, True, False, False
  Application.DisplayAlerts = True
  Columns("A").Resize(, Cells(1, Columns.Count).End(xlToLeft).Column).AutoFit
End Sub[/td]
[/tr]
[/table]

 

[adamelston]

Thanks!

.

Option Explicit


Sub RotList2()
Application.ScreenUpdating = False
Range("A3:B302").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B3:B302") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:B302")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Sheet1").Range("A1").Select
Application.ScreenUpdating = True
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/2ZJCD3YmnwEHwZVIq7l3zPEiZDbXhHwvKlR6nwtVQia

 

[adamelston]

Thanks!

 

[Logit]

.
You are welcome.