Production Call In List

[Robandemmy]

Hello,

I am trying to help a business unit a a factory I work at with their on call/call in list for covering occasional absences (if someone calls in sick, the shift supervisor uses this list to know who to call for coverage).

I have something that I borrowed from a sister factory but because we are a bit smaller, it's not working for us. It has tabs for each of the 4 crews and this macro to generates a list that calendar tabs use to lookup employee names:

Sub Construction()
'definition  of the variables
Dim Crew As Long
Dim Crew1 As Long
Dim Crew2 As Long
Dim Crew3 As Long
Dim Crew4 As Long
Dim positionCrew1 As Long
Dim positionCrew2 As Long
Dim positionCrew3 As Long
Dim positionCrew4 As Long
Dim I As Long
Dim InputStartDate As String
Dim StartDate As Date
Dim StartLine As Long
Dim myTableArray As Range
Dim myVLookupResult As Long

Line0A:
InputStartDate = ""

'Ask at what date the update has to start to allow changes during the year
InputStartDate = InputBox("What date do you want to start building the call-in list?", "Please enter the date", "MM/DD/YYYY")
'If the user clicks on cancel then go to Line6
If StrPtr(InputStartDate) = 0 Then GoTo Line6

'Check if the input is a date
Do Until IsDate(InputStartDate) = True
    MsgBox ("Please enter a date MM/DD/YYYY")
    GoTo Line0A
Loop
StartDate = InputStartDate
'Check if the input is a valide date within the current year set up in the calendar file in column 10 line 1
If Year(StartDate) <> Sheets("calendar").Cells(1, 10) Then
    MsgBox ("Please enter a date MM/DD/YYYY within the year: " & Sheets("calendar").Cells(1, 10))
    GoTo Line0A
Else: GoTo Line0B
End If
Line0B:
'Set the #employees per crew
Crew1 = Sheets("Crew1").Cells(1, 3).Value
Crew2 = Sheets("Crew2").Cells(1, 3).Value
Crew3 = Sheets("Crew3").Cells(1, 3).Value
Crew4 = Sheets("Crew4").Cells(1, 3).Value


'Check if there is at least 1 employee for each crew
If Crew1 = 0 Then
    MsgBox ("Please add employees in Crew 1")
    GoTo Line6
End If

If Crew2 = 0 Then
    MsgBox ("Please add employees in Crew 2")
    GoTo Line6
End If

If Crew3 = 0 Then
    MsgBox ("Please add employees in Crew 3")
    GoTo Line6
End If
If Crew4 = 0 Then
    MsgBox ("Please add employees in Crew 4")
    GoTo Line6
End If

I = 0

positionCrew1 = 1
positionCrew2 = 1
positionCrew3 = 1
positionCrew4 = 1

'Define who is the next to be on call based on the person who was the last on call before the update (x in the crew list)
Do Until Sheets("crew1").Cells(positionCrew1 + 3, 4).Value = "x"
   positionCrew1 = positionCrew1 + 1
Loop
positionCrew1 = positionCrew1 + 1

Do Until Sheets("crew2").Cells(positionCrew2 + 3, 4).Value = "x"
    positionCrew2 = positionCrew2 + 1
Loop
positionCrew2 = positionCrew2 + 1


Do Until Sheets("crew3").Cells(positionCrew3 + 3, 4).Value = "x"
    positionCrew3 = positionCrew3 + 1
Loop
positionCrew3 = positionCrew3 + 1

Do Until Sheets("crew4").Cells(positionCrew4 + 3, 4).Value = "x"
    positionCrew4 = positionCrew4 + 1
Loop
positionCrew4 = positionCrew4 + 1


'Define where to start the update based on the date given by the user
StartLine = 2
Do Until Sheets("calendar").Cells(StartLine, 2) = StartDate 'as long as the date in the second column is different from the date given go to next line
        StartLine = StartLine + 1
Loop

For I = StartLine To Range("A65536").End(xlUp).Row
    If Sheets("calendar").Cells(I, 4).Value = 1 Then GoTo Line1 Else: 'if this is crew 1 then go to line1
        If Sheets("calendar").Cells(I, 4).Value = 2 Then GoTo Line2 Else: 'if this is crew 2 then go to line2
            If Sheets("calendar").Cells(I, 4).Value = 3 Then GoTo Line3 Else: GoTo Line4 'if this is crew 3 then go to line3 else go to line4

Line1:
    If positionCrew1 > Crew1 Then positionCrew1 = 1 Else 'if we are at the end of the crew list then go back to the beginning
        'if there is no name in this position go to line 1A else go to line 1B
        If Sheets("crew1").Cells(positionCrew1 + 3, 2).Value = "" Then GoTo Line1A Else: GoTo Line1B
Line1A:
    Do Until Sheets("crew1").Cells(positionCrew1 + 3, 2).Value <> "" 'As long as there is no name for this position go to next position
        positionCrew1 = positionCrew1 + 1
    Loop
Line1B:
    Sheets("calendar").Cells(I, 5) = Sheets("crew1").Cells(positionCrew1 + 3, 2) 'Add the name of the crew member in the call in calendar for this day/shift
    positionCrew1 = positionCrew1 + 1 'Go to the next crew team member in the list
GoTo Line5
    
Line2:
    If positionCrew2 > Crew2 Then positionCrew2 = 1 Else
       If Sheets("crew2").Cells(positionCrew2 + 3, 2).Value = "" Then GoTo Line2A Else: GoTo Line2B
Line2A:
    Do Until Sheets("crew2").Cells(positionCrew2 + 3, 2).Value <> ""
        positionCrew2 = positionCrew2 + 1
    Loop
Line2B:
    Sheets("calendar").Cells(I, 5) = Sheets("crew2").Cells(positionCrew2 + 3, 2)
    positionCrew2 = positionCrew2 + 1
GoTo Line5
    
Line3:
    If positionCrew3 > Crew3 Then positionCrew3 = 1 Else
        If Sheets("crew3").Cells(positionCrew3 + 3, 2).Value = "" Then GoTo Line3A Else: GoTo Line3B
Line3A:
    Do Until Sheets("crew3").Cells(positionCrew3 + 3, 2).Value <> ""
        positionCrew3 = positionCrew3 + 1
    Loop
Line3B:
    Sheets("calendar").Cells(I, 5) = Sheets("crew3").Cells(positionCrew3 + 3, 2)
    positionCrew3 = positionCrew3 + 1
GoTo Line5

Line4:
    If positionCrew4 > Crew4 Then positionCrew4 = 1 Else
        If Sheets("crew4").Cells(positionCrew4 + 3, 2).Value = "" Then GoTo Line4A Else: GoTo Line4B
Line4A:
    Do Until Sheets("crew4").Cells(positionCrew4 + 3, 2).Value <> ""
        positionCrew4 = positionCrew4 + 1
    Loop
Line4B:
    Sheets("calendar").Cells(I, 5) = Sheets("crew4").Cells(positionCrew4 + 3, 2)
    positionCrew4 = positionCrew4 + 1
GoTo Line5

Line5:
    Next I 'Go to next line of the calendar
Line6:
End Sub

So the file essentially looks at what crew is working, what the coverage crew is and assigns an employee from that list to be on call or stand by. With our schedule (Repeating 4 week schedule of days and nights , employees work 14 days and are off 14 days. The problem with the file is when a crew has 7 employees...the employees on that crew then become on call on the same day of the week everytime, where as shorter or heavier crews of 6 or 8 end up being more varied.

So my question becomes this...is there a way to add an element of randomness? Would still need the employees to be on call the same number of times but have a way to ensure that they are not on call the same day all of the time.

I know that's a lot, but I appreciate any help!

Thanks,
Rob

 

[Micron]

I would have thought it easier to always manually choose given that life has a way of upsetting automation like this. Or consider manually choosing the first person in a crew, marking their row with x and then randomly choose from the remainder?
Sorry for not trying to digest all of that code but it's not well written so it's hard to follow. Maybe my answer isn't of much help as a result.