Assign Name to a group (VBA)

[rpaulson]

I have a list of people name in column A. starting in cell A1 ,There is anywhere from 10 to 100 names on the list.

I need to assign these people to a class room number (Room A, B, C .....) there may be up to 9 rooms available on any given day.

I am looking for VBA code to assign the people into a room. by putting the room number in column B

I will use:

people= Cells(Rows.Count, "A").End(xlUp).Row 'this will tell me how many people are registered
rooms= inputbox ("How many rooms are available today") 'number of groups to break the list into

I know i could go Down the list and write A,B,C,D then A,B,C,D then A,B,C,D etc... but that is not what i want.
i want the list to go A,A,A,A B,B,B,B, C,C,C,C D,D,D,D, .....

Examples.

43 people and 5 rooms - Room A would have the first 9 people on the list, Room B the next 9, Room C the next 9, Room D then next 8 and Room E the last 8
17 people and 3 rooms - Room A would have the first 6 people on the list, Room B the next 6, Room C the last 5.
49 people and 4 rooms - A would have first 13, B next 12, C next 12, and D last 12


thanks for looking,
-Ross

 

[Jeffrey Mahoney]

This is pretty raw, but it's a start. This requires that you put the number of rooms in Cell E1 or change that location in the code.

Sub AssignRoom()
  Dim R As Range
  Dim Cel As Range
  Dim Tot As Long
  Dim Div As Long
  Dim Cnt As Long
  Dim Rooms As Long
  Dim RmCnt As Long
  Dim RmLetters As String
  Dim RmLtr As String
  
  RmLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  
  Set R = Range(Range("A1"), Range("A1").End(xlDown))
  Tot = R.Rows.Count
  Rooms = Range("E1").Value
  Div = Tot / Rooms
  If Rooms > 26 Then
    MsgBox "There can only be 26 rooms"
    Exit Sub
  End If
  
  For Each Cel In R
    If RmCnt = 0 Then
      RmCnt = 1
    End If
    Cnt = Cnt + 1
    If Cnt > Div Then
      RmCnt = RmCnt + 1
      Cnt = 1
    End If
    RmLtr = Mid(RmLetters, RmCnt, 1)
    Cel.Offset(0, 1) = RmLtr
  Next Cel
    
  
  
End Sub

 

[Jeffrey Mahoney]

If you need, add some code for the user to input the number rooms.

Rooms = InputBox("Please enter the number of rooms", "Room Number")

 

[rpaulson]

Jeff,

close -seems to be some issue.

when 31 people and 3 rooms . it put 10 in room A,B & C, and 1 in room D
it should be 11,10,10

with 41 and 8 it also leave the last peron in Room i all by himself.

 

[Jeffrey Mahoney]

Well, you have the framework. I have a solution. We just need to calculate the remainder and add it to the first rooms. Lookup MOD. NumPeople mod NumRooms = remainder. Add a variable to store that: Rmndr.

BRB

 

[Jeffrey Mahoney]

A little more complexity, but I think it gets you there.

Sub AssignRoom()
  Dim R As Range
  Dim Cel As Range
  Dim Tot As Long
  Dim Div As Long
  Dim Cnt As Long
  Dim Rooms As Long
  Dim RmCnt As Long
  Dim RmLetters As String
  Dim RmLtr As String
  Dim Rmndr As Long
  Dim DivTemp As Long
  
  RmLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  
  Set R = Range(Range("A1"), Range("A1").End(xlDown))
  Tot = R.Rows.Count
  Rooms = InputBox("Please enter the number of rooms", "Room Number")
  'Rooms = Range("E1").Value
  Div = Int(Tot / Rooms)
  Rmndr = Tot Mod Rooms
  
  If Rooms > 26 Then
    MsgBox "There can only be 26 rooms"
    Exit Sub
  End If
  
  RmCnt = 1
  If Rmndr > 0 Then
    DivTemp = Div + 1
    Rmndr = Rmndr - 1
  Else
    DivTemp = Div
  End If
  For Each Cel In R
    Cnt = Cnt + 1
    If Cnt > DivTemp Then
      RmCnt = RmCnt + 1
      Cnt = 1
      If Rmndr > 0 Then
        DivTemp = Div + 1
        Rmndr = Rmndr - 1
      Else
        DivTemp = Div
      End If
    End If
    RmLtr = Mid(RmLetters, RmCnt, 1)
    Cel.Offset(0, 1) = RmLtr
  Next Cel

End Sub

 

[jolivanes]

Check and change references as required.
Amount of people is in Column E while the amount of rooms is in Column F.
The result is in 5 Columns to the right of Column E.

Sub Maybe()
Dim x As Long, i As Long, j As Long, y As Long, z As Long, c As Range, ppl
For Each c In Range("E1:E5")    '<----- Change as required
x = c.Value Mod c.Offset(, 1).Value
    If x = 0 Then
        For i = 1 To c.Offset(, 1).Value
            ppl = ppl & "," & c.Value / c.Offset(, 1).Value
        Next i
        c.Offset(, 5).Value = Mid(ppl, 2)    '<----- Change Offset Column as required
    Else
        y = WorksheetFunction.RoundUp(c.Value / c.Offset(, 1).Value, 0)
        z = y - 1
        For i = 1 To x
            ppl = ppl & "," & y
        Next i
        For j = 1 To c.Offset(, 1).Value - x     '+ 1 To c.Offset(, 1).Value
            ppl = ppl & "," & z
        Next j
        c.Offset(, 5).Value = Mid(ppl, 2)
    End If
ppl = ""
j = 0
i = 0
Next c
End Sub

 

[jolivanes]

A little shorter code.
Amount of people in Column E and amount of rooms in Column F. Result in Column H.

Sub Maybe_2()
Dim c As Range, x As Long, xx As Long, y As Long, z As Long
    For Each c In Range("E1:E5")
        x = c.Value Mod c.Offset(, 1).Value
            xx = c.Offset(, 1).Value - x
                y = WorksheetFunction.RoundUp(c.Value / c.Offset(, 1).Value, 0)
                    z = y - 1
                c.Offset(, 3).Value = WorksheetFunction.Rept("," & y, x)
            c.Offset(, 3).Value = c.Offset(, 3).Value & WorksheetFunction.Rept("," & z, xx)
        c.Offset(, 3).Value = Mid(c.Offset(, 3).Value, 2)
    Next c
End Sub

Have to change in case x = 0

 

[jolivanes]

Sub Maybe_2()
Dim c As Range, x As Long, xx As Long, y As Long, z As Long
    For Each c In Range("E1:E" & Cells(Rows.Count, 5).End(xlUp).Row)
        x = c.Value Mod c.Offset(, 1).Value
         If x = 0 Then
            c.Offset(, 3).Value = WorksheetFunction.Rept("," & c.Value / c.Offset(, 1).Value, c.Offset(, 1).Value)
            Else
                xx = c.Offset(, 1).Value - x
                    y = WorksheetFunction.RoundUp(c.Value / c.Offset(, 1).Value, 0)
                        z = y - 1
                    c.Offset(, 3).Value = WorksheetFunction.Rept("," & y, x)
                c.Offset(, 3).Value = c.Offset(, 3).Value & WorksheetFunction.Rept("," & z, xx)
            End If
        c.Offset(, 3).Value = Mid(c.Offset(, 3).Value, 2)
    Next c
End Sub

 

[jolivanes]

If it is a single calculation, you might want it in a message box.

Sub Maybe_3()
Dim ppl As Long, rms As Long, i As Long, x As Long, xx As Long, y As Long, z As Long, ttl, arr, ppl_rms
ppl = Application.InputBox(Prompt:="Total amount of people", Title:="People for the course", Type:=1)
rms = Application.InputBox(Prompt:="Amount of rooms available (max = 26)", Title:="Rooms for the course", Type:=1)
If rms > 26 Then MsgBox "You have too many rooms. Maximum is twenty six rooms.": Exit Sub
    x = ppl Mod rms
         If x = 0 Then
            ttl = WorksheetFunction.Rept("," & ppl / rms, rms)
            Else
                xx = rms - x
                    y = WorksheetFunction.RoundUp(ppl / rms, 0)
                        z = y - 1
                    ttl = WorksheetFunction.Rept("," & y, x)
                ttl = ttl & WorksheetFunction.Rept("," & z, xx)
            End If
        arr = Split(Mid(ttl, 2), ",")
        ppl_rms = "People per room:" & vbLf
    For i = LBound(arr) To UBound(arr)
        ppl_rms = ppl_rms & vbLf & "Room " & Chr(65 + i) & " = " & arr(i)
    Next i
MsgBox ppl_rms
End Sub