VBA to autofill a work schedule

Dustinkli

Board Regular
Joined
Mar 26, 2019
Messages
62
Office Version
  1. 365
  2. 2011
Platform
  1. Windows
I am responsible for making work schedules at my job and I do them in a way where different people are assigned different tasks on different days of the week. Also, each weekend 2 people work and they get 2 days off during the week as well.

I would like to get any ideas on a way I can make a VBA that automatically fills out the blank days on the schedule while meeting certain rules (i.e. No one gets assigned the same thing on the same day and ,IF possible, no one gets assigned the task twice in a week).

The monthly schedule is formatted like this:

MondayTuesdayWednesdayThursdayFridaySaturdaySundayMondayTuesdayWednesday
BobTask ATask CTask BOffOffTask ATask C
AmberTask BTask ATask COffOffTask BTask A
JasonTask CTask BTask ATask ATask BOffOffTask C
AmeliaOffTask CTask BTask ATask BTask AOffOffTask B
BillOffOffTask CTask BTask AOffOffTask CTask BTask A

What I'd like to do is be able to set up the schedule with requested days off first then run the VBA and it automatically fills out the rest of the schedule with scheduled tasks per the specified rules leaving what is already there alone.

I'm not sure where to begin with this so I wanted to get some input and tips on where I should start or if anyone has encountered something similar to this already written which I can modify to suit my purposes.
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Dustinkli I don't think filling out your schedule can be accomplished, given your rules. I mean forget VBA, How would you fill out your schedule. What would you put in the blank cells. In my opinion you are going to have to come up with more Tasks. Also what is a normal work week? Bill looks like he works 3 days. Below is a couple of examples of what a 2 task and 3 task would look like.



Book1
ABCDEFGHIJKL
1MondayTuesdayWednesdayThursdayFridaySaturdaySundayMondayTuesdayWednesdayThursday
2BobOffOffTask ATask BOffOff
3AmberOffOffTask BTask AOffOff
4BillTask ATask BOffOffTask ATask B
5SteveTask BTask AOffOffTask BTask A
2 Tasks



Book1
ABCDEFGHIJKL
1MondayTuesdayWednesdayThursdayFridaySaturdaySundayMondayTuesdayWednesdayThursday
2BobOffOffOffTask ATask BTask C
3AmberOffOffOffTask BTask CTask A
4BillOffOffOffTask CTask ATask B
5SteveTask ATask BTask COffOffOff
6JasonTask BTask CTask AOffOffOff
7AmeliaTask CTask ATask BOffOffOff
3 Tasks
 
Upvote 0
I may not have explained the rules very clearly, that's my fault. Here are the basic rules:

1. If possible, each person gets each task once per week.
2. If possible, no one gets the same task twice per week.
3. No one ever gets the same task on the same day.
4. On weekends only Task A and Task B need to be done, not task C.

Here is an example of what the schedule would look like doing it manually following the previously mentioned rules:

SaturdaySundayMondayTuesdayWednesdayThursdayFridaySaturdaySundayMondayTuesdayWednesdayThursdayFriday
BobOffOffTask ATask CTask BTask AOffOffTask C
AmberTask ATask BOffOffTask CTask BOffOffTask ATask B
BillOffOffTask BTask ATask COffOffTask BTask ATask C
SteveOffOffTask CTask BTask AOffOffTask CTask BTask A
JasonTask BTask AOffOffTask BTask AOffOffTask CTask BTask A
AmeliaOffOffTask CTask BTask ATask ATask BOffOffTask CTask BTask A
 
Upvote 0
Dustinkli Now this is better. The more information we get the better we can come to a solution. What we need now is for you to fill in the blanks using the example above. We need to see an example of the output you would like to see. Once you show us how you would fill in the blanks using the example above, then we will be able to come up with a VBA program. So fill in the blanks and post it here.
 
Upvote 0
Dustinkli Now this is better. The more information we get the better we can come to a solution. What we need now is for you to fill in the blanks using the example above. We need to see an example of the output you would like to see. Once you show us how you would fill in the blanks using the example above, then we will be able to come up with a VBA program. So fill in the blanks and post it here.


The last posted schedule is the Output I would like to have. So assume the schedule is blank to start with then I fill in cells for requested days off or scheduled weekends or other things I'd like. Then, after I fill a few cells in, I run the VBA and it does the rest.

There are only 3 tasks: Task A, Task B and Task C. Each task must be assigned to 1 person once per weekday. Task A and Task B only on weekends.
 
Upvote 0
Dustinkli I have to ask you this question, what does Bob do on Wednesday? If it's a blank cell does that mean he takes the day off with no work? And if that is a true statement then can we type the word off in that Wednesday blank cell?
 
Upvote 0
Dustinkli I have to ask you this question, what does Bob do on Wednesday? If it's a blank cell does that mean he takes the day off with no work? And if that is a true statement then can we type the word off in that Wednesday blank cell?

The only time someone is off work is when it says "Off". Bob, on Wednesday, does not have a specified assignment so he just takes phone calls all day.
 
Upvote 0
Alright I have an idea for you. I've built this so you can add task and employees as needed. As well as scheduled out as long as you want

Step 1 Create a worksheet named "TaskSheet" and in column A list out your task. One per row. No Header.
1602252512303.png


Next create a worksheet named Schedule
This you will populate with the employees and days you want scheduled.
1602252572569.png

You can put anything in the cells to indicate OFF. So if you want to specify Regular day off vs a Vacation Day you can, it doesn't matter as long as the cells to be filled are blank

Now open the VBA editor for this sheet. and use this code:
This code will first check to see if there are enough employees working to do all the task. If not you will get a warning letting you know the day that is short
1602252984466.png


Next it rolls through the task, starts with the first employee and see's if they are free. If they are free and have not done the task in the past 7 days it gives it to them. Other wise it goes to the next employee.

If all the employees who CAN do the task have done the task in the past 7 days, it goes back and starts over at the top and gives it to the first free person.

This is a place for future improvement, it could check to see WHEN the last time each person did it and give it to the person who did the the longest ago, but I did not write out that logic

It then finishes through all the shifts and task for all days scheduled


Code:
Sub FillSchedule()

Dim TotalEmp As Integer
TotalEmp = 2
Dim ws As Worksheet
Set ws = Me


Do Until ws.Cells(TotalEmp, 1) = ""
    TotalEmp = TotalEmp + 1
Loop

Dim TskSt As Worksheet
Dim TotalTask As Integer

Set TskSt = ThisWorkbook.Sheets("TaskSheets")
TotalTask = 1
Do Until TskSt.Cells(TotalTask, 1) = ""
    TotalTask = TotalTask + 1
Loop


Schday = 2
Do Until ws.Cells(1, Schday) = ""
    'Roll Back is used to check a rolling week for the task
    If Schday < 8 Then RollBack = 2 Else RollBack = Schday - 7
   
    'Check to see if there are enough employees for task
    If Application.WorksheetFunction.CountBlank(ws.Range(ws.Cells(2, Schday), ws.Cells(TotalEmp - 1, Schday))) < TotalTask - 1 Then MsgBox ("Not enough Employees for all task on " & ws.Cells(1, Schday) & ".")
   
   
    DoubleTask = False
    For AllTsk = 1 To TotalTask - 1
        AssignedTask = False
        For AllEmps = 2 To TotalEmp - 1
            DoneTask = WorksheetFunction.CountIf(ws.Range(ws.Cells(AllEmps, RollBack), ws.Cells(AllEmps, Schday)), TskSt.Cells(AllTsk, 1))
           
            If ws.Cells(AllEmps, Schday) = "" And (DoneTask = 0 Or DoubleTask = True) Then
                ws.Cells(AllEmps, Schday) = TskSt.Cells(AllTsk, 1)
                AssignedTask = True
                Exit For
            End If
           
        Next
       
        If AssignedTask = False And DoubleTask = False Then
            DoubleTask = True
            AllTsk = AllTsk - 1
        End If
    Next


    Schday = Schday + 1
Loop



End Sub

The output looks like this Note one Saturday and Sunday, Task C did not post because there was not enough people schedule:

1602252921913.png
 
Upvote 0
Alright I wasn't happy with the doubling of task. So I've figured out that logic. Use this code instead (I'm sure it could be cleaned up some)

Code:
Sub FillSchedule()

Dim TotalEmp As Integer
TotalEmp = 2
Dim ws As Worksheet
Set ws = Me


Do Until ws.Cells(TotalEmp, 1) = ""
    TotalEmp = TotalEmp + 1
Loop

Dim TskSt As Worksheet
Dim TotalTask As Integer

Set TskSt = ThisWorkbook.Sheets("TaskSheets")
TotalTask = 1
Do Until TskSt.Cells(TotalTask, 1) = ""
    TotalTask = TotalTask + 1
Loop


Schday = 2
Do Until ws.Cells(1, Schday) = ""
    'Roll Back is used to check a rolling week for the task
    If Schday < 8 Then RollBack = 2 Else RollBack = Schday - 7
    
    'Check to see if there are enough employees for task
    If Application.WorksheetFunction.CountBlank(ws.Range(ws.Cells(2, Schday), ws.Cells(TotalEmp - 1, Schday))) < TotalTask - 1 Then MsgBox ("Not enough Employees for all task on " & ws.Cells(1, Schday) & ".")
    

    DoubleTask = False
    Resch = 999999
    For AllTsk = 1 To TotalTask - 1
 
        AssignedTask = False

        For AllEmps = 2 To TotalEmp - 1
            DoneTask = WorksheetFunction.CountIf(ws.Range(ws.Cells(AllEmps, RollBack), ws.Cells(AllEmps, Schday)), TskSt.Cells(AllTsk, 1))
            If DoneTask > 0 And ws.Cells(AllEmps, Schday) = "" Then
                MaxTaskDate = Schday
                Do Until ws.Cells(AllEmps, MaxTaskDate) = TskSt.Cells(AllTsk, 1)
                    MaxTaskDate = MaxTaskDate - 1
                 Loop
                    If MaxTaskDate = Resch Then
                        DoubleMe = True
                    Else
                        DoubleMe = False
                    End If
                    If MaxTaskDate < Resch And DoubleTask = False Then Resch = MaxTaskDate
               

            
            End If
            
            If ws.Cells(AllEmps, Schday) = "" And (DoneTask = 0 Or (DoubleTask = True And DoubleMe = True)) Then
                ws.Cells(AllEmps, Schday) = TskSt.Cells(AllTsk, 1)
                AssignedTask = True
                Resch = 999999
                DoubleMe = False
                Exit For
            End If
            
        Next
        
        If AssignedTask = False And DoubleTask = False Then
            DoubleTask = True
            AllTsk = AllTsk - 1
        
        End If
        If AssignedTask = True Then
            DoubleTask = False
            Resch = 9999
        End If
    Next


    Schday = Schday + 1
Loop



End Sub

new output:

1602255078750.png
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,172
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top