6 admins, 100 staff

[Jimmasterton]

Hi experts, I m back with another vague and cryptic problem, and I ll be honest and say this probably isnt even do able.

Imagine an office with 106 staff , 6 admins responsible for organising the appointments of 100 staff. A random schedule needs to be designed on a weekly basis (daily if there’s one of the 6 admins on leave or sick)

I have created a worksheet with the 6 admins names down the left hand side (A10, A15, A20 so on) next to each admin name I need an on off device to take into account if they should be included in the split of work
Each admin has a color assigned to them .

On the right hand side of the sheet a ten by ten table with the hundred staff names

What I would like to do is hit a button and have the 100 name table covered with a random but fairly even split of work, taking into account the admins that are off.

Is this even possible?!?

 

[Jimmasterton]

Worked like a charm Eric! Your experience and knowledge shine through. Seems I have a lot to learn. Just one small and perhaps trivial thing, when the summary is generated, the admin names and work randomises. Would it be possible to keep the admin names static and have the staff names jump to the appropriate admin?

 

[Eric W]

Try this:

Sub Assign()
Dim ad As Long, Admins(1 To 6) As Long, r As Long, x As Long, sw1 As Long
Dim MyColors As Variant, MyKeys(1 To 100) As Long, c1 As Range, MyTab As Range, SumTab As Worksheet
    
' Define the parameters
    Set MyTab = Range("H11")
    MyColors = Array(3, 4, 5, 6, 7, 8)
    Set SumTab = Worksheets("Sheet3")
    
' Clear the summary sheet
    SumTab.Cells.ClearContents
    SumTab.Cells.Interior.ColorIndex = 0

' Find out how many admins we have, look at A10,A15,A20,A25,A30,A35 and count the FALSEs.  A FALSE means
' the admin is available, a TRUE means absent.  This is set by the checkboxes.
    ad = 0
    For r = 10 To 35 Step 5
        c = r / 5 - 1
        Admins(c) = -1                                          ' say the admin is not available
        SumTab.Cells(1, c) = Cells(r, "A")
        SumTab.Cells(1, c).Interior.ColorIndex = MyColors(c - 1)
        If Cells(r, "B") = False Then
            ad = ad + 1
            Admins(c) = c                                       ' nope, the admin is available
        End If
    Next r
    If ad = 0 Then
        MsgBox "No admins available!", vbCritical
        Exit Sub
    End If
   
    Randomize
    
' Now randomly sort the admins, so that if the number of assignments isn't even, then
' the extra assignments don't always go to the same admin.
' We sort by going through the whole list, and switching each name with a random position.
    For r = 1 To 6
        x = Int(Rnd() * 6) + 1
        sw1 = Admins(r)
        Admins(r) = Admins(x)
        Admins(x) = sw1
    Next r
  
' Set up an array from 0 to 99, representing each cell in the table.  If you divide a
' number from 0 to 99 by 10, the quotient is the row, and the remainder is the column.
    For r = 1 To 100
        MyKeys(r) = r - 1
    Next r
 
' Clear the colors from the table
    MyTab.Resize(10, 10).Interior.ColorIndex = 0
    
' Go through the list.  We randomly pick a number from the list and assign it to the
' next admin.  Then we remove that number from the list by replacing it with the last
' number left on the list.  c represents the number of the next admin to use.
    c = 0
    For r = 1 To 100
        x = Int(Rnd() * (101 - r)) + 1
        Set c1 = MyTab.Offset(MyKeys(x) \ 10, MyKeys(x) Mod 10)
        If c1.Value <> "" Then
            Do
                c = IIf(c = 6, 1, c + 1)
            Loop Until Admins(c) <> -1
            c1.Interior.ColorIndex = MyColors(Admins(c) - 1)         ' set the color
            SumTab.Cells(Rows.Count, Admins(c)).End(xlUp).Offset(1).Value = c1.Value  ' save the name on the summary tab
        End If
        MyKeys(x) = MyKeys(101 - r)
    Next r
    
End Sub

I took out a few things that were unnecessary, but the general flow is the same.

Have a great weekend!

 

[Jimmasterton]

Perfect Eric! Thank you very much, you are a credit to this board. I have a feeling not too many people would be so keen to impart the knowledge you have. Perhaps you’re from a teaching background? Anyway, you saved me a lot of work, I’m extremely grateful!

 

[Eric W]

No formal teaching background, although maybe someday. In any event, I'm glad it works for you!

 

[Jimmasterton]

Hello Eric and fellow experts

I have another big ask of you. This code is working incredibly well but I wondered if one last addition was possible.

I wanted to introduce a facility of ‘locking’ the generated choices, so in column C there might be a true/false value with checkbox that locks the generation of random selections and preserves the choices, thereby allowing the unlocked and ‘absent’ admins’ work to be added to the locked admins.

Does that make sense? Probably not.

I thought about this idea of adding an exit sub statement if values in C column were true, but that won’t take into account the unlocked and absent admins.

To be honest, this code is so over my head I feel totally out of my depth.

Your help as always is very much appreciated

 

[Eric W]

Well, your request doesn't quite make sense to me!

Maybe the best I can surmise is that you want a "restart" mode. I picture that you set up your table, and checked which admins were absent or not, then ran the macro. Then later, you added some more entries to the table, and some more admins are available. You want to assign out the new entries, but leave the current ones in the list.

So at this point you want to do a restart. Somehow you tell the macro you want a restart (either a check box, or the macro can ask you, or something else), and it finds which admins are currently available (or among whom you want to assign the new items), then it goes through the table and assigns out ONLY the cells which aren't currently colored. Instead of clearing the summary sheet, it just adds the new items to the end of the lists.

Am I close? We could probably add another macro, so that you can delete an entry from your table, and it will automatically remove the color, and possibly remove it from the summary sheet. That would make it easier to add items to a table.

Let me know.

 

[Jimmasterton]

Hi Eric, great to hear from you again.

I know, this didn’t make much sense. Let me try another way.

I’m very happy with the number of admins (6) and the number of staff (100). That’s all good.

I put out this split of work every week to the staff on a Friday night for the following Monday. This schedule suits them all week until I do another split the following Friday. But, let’s just say that admin no 2 (Bob) is off sick on Monday, and I’ve already sent out the split of work. Instead of hitting the randomiser button again I want to ‘lock’ or preserve the other admins workload and make bobs work add to their lists. ?!?

 

[Eric W]

Give this a try:

Sub Assign()
Dim ad As Long, Admins(1 To 6) As Long, r As Long, x As Long, sw1 As Long
Dim MyColors As Variant, MyKeys(1 To 100) As Long, c1 As Range, MyTab As Range, SumTab As Worksheet
Dim ans As Long, GoodColors As String, msg1 as String
    
' Figure out if it's a regular run, or a redistibute

    msg1 = "Please click 'Yes' if this should start from scratch." & vbLf & vbLf
    msg1 = msg1 & "Please click 'No' if you want to redistribute names if admin availability has changed." & vbLf & vbLf
    msg1 = msg1 & "Press 'Cancel' to exit with no action."
    ans = MsgBox(msg1, vbYesNoCancel, "Randomizer")
    If ans = vbCancel Then Exit Sub
    
' Define the parameters
    Set MyTab = Range("H11")
    MyColors = Array(3, 4, 5, 6, 7, 8)
    Set SumTab = Worksheets("Sheet3")
    
' Clear the summary sheet for a full run
    If ans = vbYes Then
        SumTab.Cells.ClearContents
        SumTab.Cells.Interior.ColorIndex = 0
    End If

' Find out how many admins we have, look at A10,A15,A20,A25,A30,A35 and count the FALSEs.  A FALSE means
' the admin is available, a TRUE means absent.  This is set by the checkboxes.
    ad = 0
    GoodColors = "."
    For r = 10 To 35 Step 5
        c = r / 5 - 1
        Admins(c) = -1                                          ' say the admin is not available
        SumTab.Cells(1, c) = Cells(r, "A")
        SumTab.Cells(1, c).Interior.ColorIndex = MyColors(c - 1)
        If Cells(r, "B") = False Then
            ad = ad + 1
            Admins(c) = c                                       ' nope, the admin is available
            GoodColors = GoodColors & MyColors(c - 1) & "."
        Else
            SumTab.Cells(2, c).Resize(100, 1).ClearContents
        End If
    Next r
    If ad = 0 Then
        MsgBox "No admins available!", vbCritical
        Exit Sub
    End If
   
    Randomize
    
' Now randomly sort the admins, so that if the number of assignments isn't even, then
' the extra assignments don't always go to the same admin.
' We sort by going through the whole list, and switching each name with a random position.
    For r = 1 To 6
        x = Int(Rnd() * 6) + 1
        sw1 = Admins(r)
        Admins(r) = Admins(x)
        Admins(x) = sw1
    Next r
  
' Set up an array from 0 to 99, representing each cell in the table.  If you divide a
' number from 0 to 99 by 10, the quotient is the row, and the remainder is the column.
    For r = 1 To 100
        MyKeys(r) = r - 1
    Next r
 
' Clear the colors from the table
    If ans = vbYes Then MyTab.Resize(10, 10).Interior.ColorIndex = 0
    
' Go through the list.  We randomly pick a number from the list and assign it to the
' next admin.  Then we remove that number from the list by replacing it with the last
' number left on the list.  c represents the number of the next admin to use.
    c = 0
    For r = 1 To 100
        x = Int(Rnd() * (101 - r)) + 1
        Set c1 = MyTab.Offset(MyKeys(x) \ 10, MyKeys(x) Mod 10)
        If c1.Value <> "" Then
            If InStr(GoodColors, "." & c1.Interior.ColorIndex & ".") = 0 Then
                Do
                    c = IIf(c = 6, 1, c + 1)
                Loop Until Admins(c) <> -1
                c1.Interior.ColorIndex = MyColors(Admins(c) - 1)         ' set the color
                SumTab.Cells(Rows.Count, Admins(c)).End(xlUp).Offset(1).Value = c1.Value  ' save the name on the summary tab
            End If
        End If
        MyKeys(x) = MyKeys(101 - r)
    Next r
    
End Sub

Not a lot of changes needed. When you run it Friday night, use the 'Yes' button on the message box. If you have to rerun it on Monday, check Bob's box to indicate that he's unavailable, rerun the macro and use the 'No' button.

 

[Jimmasterton]

Absolute perfection Eric! I will surely be able to take little bits from this for future projects, and I know it’s not much but I managed to add a reserve admin. So learning all the time

Many, many thanks for making my working day so much easier. Have a great weekend.

 

[Eric W]

Very glad it works for you. And good job adding the reserve admin. A little something here, a little something there, and you'll be a whiz in no time!