Students seats

[Chliapas Dimitrios]

Good evening,
i am new to vba and would like your valuable advice.
I am a teacher and I have a class with 14 students.
I want the students to sit with a different student every day.
I have the pairs of students and I want to rank them all in the five working days periodically but not repeat.
How can I achieve this using vba?
I am attaching the example.
Thanks in advance for your valuable help.

 

[Legacy 143009]

Kalispera from Turkey!

I want to help you but I didn't understand some of the positions. For insrance Teodgra (i hope i got it true) has always seat 6. Or Vaolvki (the first student ) has always seat 1. Is it supposed to be like this? Will some students be stationary and others will rotate?

Could you please also share a desired result table please?

 

[Chliapas Dimitrios]

Thanks a lot for the help.
Positions are not fixed. I tried to build it manually as I can't do it with vba. So I started by putting one student at a desk and then I switched rolled, positions until I had switched, rolled all the students with each other. The goal is that each day all students they sit with a different classmate but at the end of period time all the students have sat with all their classmates. I haven't used any code just built it by hand, so it has many errors. Thanks again for your immediate help and prompt response and reply.

 

[Legacy 143009]

Hello!
Sorry for the late answer. I hope this helps:

Sub seats()
  Dim x As Variant
  Dim i As Integer, j As Integer, f As Integer, seats As Integer, lRow As Integer, c As Integer
  Dim tempArr() As String, namesArr() As String
 
  Dim exist As Boolean

  Dim counter As Integer
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  f = ((lRow - 1) * lRow) / 2
  seats = Application.WorksheetFunction.RoundDown(lRow / 2, 0)
  ReDim tempArr(f, 1)

  counter = 0
  For i = 2 To lRow
    For j = i + 1 To lRow
      tempArr(counter, 0) = Cells(i, 1).Value
      tempArr(counter, 1) = Cells(j, 1).Value
      counter = counter + 1
    Next
  Next

  counter = 0
  c = 0
  ReDim namesArr(f, 1)
  Do While counter < f
    For i = 0 To f - 1
      exist = False
      For j = (c * seats) To (seats + (c * seats)) - 1
        If tempArr(i, 0) = namesArr(j, 0) Or tempArr(i, 1) = namesArr(j, 1) Or tempArr(i, 0) = namesArr(j, 1) Or tempArr(i, 1) = namesArr(j, 0) Then
          exist = True
        End If
      Next
      If tempArr(i, 0) <> "" Then
        If Not exist Then
          namesArr(counter, 0) = tempArr(i, 0)
          namesArr(counter, 1) = tempArr(i, 1)
          counter = counter + 1
          tempArr(i, 0) = ""
          tempArr(i, 1) = ""
        End If
      End If
    Next
    c = c + 1
  Loop

  Application.ScreenUpdating = False
  j = 2
  c = 4
  For i = 1 To f
    Cells(j, c).Value = namesArr(i - 1, 0)
    Cells(j + 1, c).Value = namesArr(i - 1, 1)
    j = j + 3
    If i Mod seats = 0 Then
      j = 2
      c = c + 1
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Chliapas Dimitrios]

Good Evening,
You don't need to say sorry.
I must apologize for troubling you and devoting your valuable time to help me.
Thank you very much for the help.
My knowledge is minimal in VBA and basically I expect from you the complete solution of my question.
That's why I thank you for your valuable help.
Let me inform you that when I entered the code you sent me, it gave me an error that I can neither understand nor correct.
I am sending you images from the file as I tried to make it. I also changed the names to Latin but still the error is the same.
Thank you again for your help and prompt responses.
1)

2)

Thanks again very very much.

 

[Legacy 143009]

Hi,

This is a very hard algorithm called "Round Robin" algorithm. I didn't know that. It was much harder than I thought. Much more complex than I anticipated. My previous code was a trash. I found the original algorithm and modified it for your need. Now it will work

Please note that the code will work only for even number of students. Please only run the very last function called "rotateStudents". Greetings from otherside

Private Function GenerateseatRobinOdd(ByVal num_students As Integer) As Integer()
    Dim n2 As Integer
    Dim mid As Integer
    Dim seats() As Integer
    Dim students() As Integer
    Dim i As Integer
    Dim seat As Integer
    Dim student1 As Integer
    Dim student2 As Integer

    n2 = num_students \ 2
    mid = n2 + 1
    ReDim seats(1 To num_students, 1 To num_students)

    ReDim students(1 To num_students)
    For i = 1 To num_students
        students(i) = i
    Next i

    For seat = 1 To num_students
        For i = 0 To n2 - 1
            student1 = students(mid - i)
            student2 = students(mid + i + 1)
            seats(student1, seat) = student2
            seats(student2, seat) = student1
        Next i

        student1 = students(1)
        seats(student1, seat) = 0

        RotateArray students
    Next seat

    GenerateseatRobinOdd = seats
End Function
Private Function GenerateseatRobinEven(ByVal num_students As Integer) As Integer()
    Dim seats() As Integer
    Dim seats2() As Integer
    Dim seat As Integer
    Dim student As Integer

    seats = GenerateseatRobinOdd(num_students - 1)
    ReDim seats2(1 To num_students, 1 To num_students - 1)
    For student = 1 To num_students - 1
        For seat = 1 To num_students - 1
            If seats(student, seat) = 0 Then
                seats2(student, seat) = num_students
                seats2(num_students, seat) = student
            Else
                seats2(student, seat) = seats(student, seat)
            End If
        Next seat
    Next student

    GenerateseatRobinEven = seats2
End Function
Private Function GenerateseatRobin(ByVal num_students As Integer) As Integer()
    If num_students Mod 2 = 0 Then
        GenerateseatRobin = GenerateseatRobinEven(num_students)
    Else
        GenerateseatRobin = GenerateseatRobinOdd(num_students)
    End If
End Function
Private Sub RotateArray(students() As Integer)
    Dim tmp As Integer
    Dim i As Integer

    tmp = students(UBound(students))
    For i = UBound(students) To 2 Step -1
        students(i) = students(i - 1)
    Next i
    students(1) = tmp
End Sub
Private Sub rotateStudents()
    Dim num_students As Integer
    Dim num_seats As Integer
    Dim seats() As Integer
    Dim student As Integer
    Dim seat As Integer
    Dim txt As String
    Dim lRow As Integer
    Dim r As Integer, c As Integer
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    num_students = lRow - 1
    seats = GenerateseatRobin(num_students)
 
    r = 2
    c = 4
    For seat = 1 To UBound(seats, 2)
        For student = 1 To num_students
           If student < seats(student, seat) Then
                Cells(r, c).Value = Cells(student + 1, 1).Value
                Cells(r + 1, c).Value = Cells(seats(student, seat) + 1, 1).Value
                r = r + 3
                If r Mod (((3 * num_students) / 2) + 2) = 0 Then
                c = c + 1
                r = 2
                End If
            End If
        Next student
    Next seat
End Sub

 

[Chliapas Dimitrios]

OOOOO it worked!!!!
I have no words to thank you for your valuable help and for your valuable time spent to help me.
Thank you again and again for your wonderful and valuable help.
May you and all yours always be well.
Thank you!!!!

 

[Legacy 143009]

Thanks for your beautiful feedback

 

[Legacy 143009]

Hello again!

I made a small modification to the code. Now it also rotates the students through desks. Maybe you don't need but I thought this could be a nice idea

Private Function GenerateseatRobinOdd(ByVal num_students As Integer) As Integer()
    Dim n2 As Integer
    Dim mid As Integer
    Dim seats() As Integer
    Dim students() As Integer
    Dim i As Integer
    Dim seat As Integer
    Dim student1 As Integer
    Dim student2 As Integer

    n2 = num_students \ 2
    mid = n2 + 1
    ReDim seats(1 To num_students, 1 To num_students)

    ReDim students(1 To num_students)
    For i = 1 To num_students
        students(i) = i
    Next i

    For seat = 1 To num_students
        For i = 0 To n2 - 1
            student1 = students(mid - i)
            student2 = students(mid + i + 1)
            seats(student1, seat) = student2
            seats(student2, seat) = student1
        Next i

        student1 = students(1)
        seats(student1, seat) = 0

        RotateArray students
    Next seat

    GenerateseatRobinOdd = seats
End Function
Private Function GenerateseatRobinEven(ByVal num_students As Integer) As Integer()
    Dim seats() As Integer
    Dim seats2() As Integer
    Dim seat As Integer
    Dim student As Integer

    seats = GenerateseatRobinOdd(num_students - 1)
    ReDim seats2(1 To num_students, 1 To num_students - 1)
    For student = 1 To num_students - 1
        For seat = 1 To num_students - 1
            If seats(student, seat) = 0 Then
                seats2(student, seat) = num_students
                seats2(num_students, seat) = student
            Else
                seats2(student, seat) = seats(student, seat)
            End If
        Next seat
    Next student

    GenerateseatRobinEven = seats2
End Function
Private Function GenerateseatRobin(ByVal num_students As Integer) As Integer()
    If num_students Mod 2 = 0 Then
        GenerateseatRobin = GenerateseatRobinEven(num_students)
    Else
        GenerateseatRobin = GenerateseatRobinOdd(num_students)
    End If
End Function
Private Sub RotateArray(students() As Integer)
    Dim tmp As Integer
    Dim i As Integer

    tmp = students(UBound(students))
    For i = UBound(students) To 2 Step -1
        students(i) = students(i - 1)
    Next i
    students(1) = tmp
End Sub
Private Sub rotateStudents()
    Dim num_students As Integer
    Dim num_seats As Integer
    Dim seats() As Integer
    Dim student As Integer
    Dim seat As Integer
    Dim txt As String
    Dim lRow As Integer, j As Integer
    Dim r As Integer, c As Integer
    Dim tempArr() As String
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    num_students = lRow - 1
    seats = GenerateseatRobin(num_students)
    ReDim tempArr(3 * num_students / 2)

    r = 2
    c = 4
    j = 0
    For seat = 1 To UBound(seats, 2)
        For student = 1 To num_students
           If student < seats(student, seat) Then
                Cells(r, c).Value = Cells(student + 1, 1).Value
                Cells(r + 1, c).Value = Cells(seats(student, seat) + 1, 1).Value
                r = r + 3
                If r Mod (((3 * num_students) / 2) + 2) = 0 Then
                  For i = 2 To UBound(tempArr) + 1
                    tempArr(((i - 2)+j) Mod UBound(tempArr)) = Cells(i, c).Value
                  Next
                  For i = 0 To UBound(tempArr) - 1
                    Cells(i + 2, c).Value = tempArr(i)
                  Next
                  j = j + 3
                  c = c + 1
                  r = 2
                End If
            End If
        Next student
    Next seat
End Sub

 

[Legacy 143009]

Please change this line:

j = j + 3

to this:

j = ((j + 3) * (2 ^ c)) Mod UBound(tempArr) + 3

It gives a better shuffle result.