Seeking Logic Help For VBA Solution - Determine Staff Assignments to Cover Activity Period From Available Staff

[Ark68]

Hello Excel friends,

I am struggling to find the logic for what I need to do, and hope someone can help nudge me towards a solution. If I can figure out the approach, I can start to figure out code, but I have no idea even where to start. I have the activity times - which are dynamic variables and a staff schedule, also dynamic, in a range on a worksheet.

I have an activity defined by a start time and and end time. Suppose for the purpose of discussion the start time is 8:00A and the end time is 11:00P. It takes place at centre "BP"
I have a roster of staff scheduled to work at different shifts throughout the day, at different centres of the course of the day.
What I need to do is assign one or more staff to ensure that the activity period is covered by at least one staff person working.

So, if we consider the following roster ....

wsop 22.0416.xlsm
	A	B	C	D	E
1	BPE1	7:00A	3:00P	BPC	Vacancy
2	BPL1	2:00P	10:00P	BPB	Max
3	HPE1	7:00A	3:00P	HPC	Anastasia
4	HPL1	2:00P	10:00P	HPB	Sarah
5	RPE1	7:00A	3:00P	RPC	Emily
6	RPL1	2:00P	10:00P	RPB	Chris C.
7	WPE1	7:00A	3:00P	WPC	Julianna
8	WPL1	2:00P	10:00P	WPB	Brooke
9	CUE1	7:00A	3:00P	CUA	Vacancy
10	CUL1	4:00P	12:00A	CUB	Vacancy
11	EVE1	7:00A	3:00P	CUE	Vacancy
Sheet3

Cells with Data Validation
Cell	Allow	Criteria
C5,C8	List	=nr_dsr2

Ideally, the whole activty would be ideally covered by staff working at that centre (BP), so first choices are staff BPE and BPL.

So, the solution I am trying to figure out would determine that BPE1 could cover from 8:00A - 3:00P, then BPL1 would take 3:00P - 9:00P and the remainder by CUL1. Ideally, I'd prefer the crews to cover the 50% of the two overlap, so like this ...

BPE1 and BPL1 overlap 2:00P - 3:00P, and BPL1 and CUL1 overlap 4:00P - 10:00P so BPE1 would cover 8:00A - 2:30P, BPL1 2:30 - 7:00P, and CUL1 7:00P - 11:00P.

Now suppose, any one of those shifts wasn't there. Lets take out BPE1 out of the schedule. This would leave the activity unstaffed between 8:00A and 2:00P when BPL1 starts. So, we would find the next eligible (trained for that centre) staff available. This list of alternates is available in range on worksheet "lists2".

wsop 22.0416.xlsm
	AG	AH	AI	AJ	AK	AL
3	CUE1	BP	HP	RP	WP	SE
4	CUE2	RP	BP	BP	CU	CU
5	CUL	HP	RP	HP
6		WP	WP	WP
7		CU	CU	CU
LISTS2

From the corresponding column represented by the centre, BP in our case (column AH), we would choose the next available "shift" in the series of cells from the remainder of values in that column. So, in this case, RP would be checked from the staff schedule if they would be available. RPE1 is scheduled 7:00A - 3:00P, so they could fill this vacant span. If RPE wasn't available, HPE1 working 7:00A - 3:00P could.

So, in this second example, the solution would look like:
RPE1 and BPL1 overlap 2:00P - 3:00P, and BPL1 and CUL1 overlap 4:00P - 10:00P so RPE1 would cover 8:00A - 2:30P, BPL1 2:30 - 7:00P, and CUL1 7:00P - 11:00P.

If we consider an activity period of 9:00A - 12:00P at HP, the solution would be:
HPE1 would cover 9:00A - 12:00P solely.

If we consider an activity period of 2:00P - 7:00P at WP, the solution would be:
WPE1 would cover 2:00P - 2:30P and WPL would cover 2:30P - 7:00P. Although, since WPL1 is scheduled 1:00P - 9:00P, it would be nice if the logic could reflect its more logical for them to do the whole thing (we can say an hour).

I hope I'm not asking a lot, it has become a hurdle which has consumed a lot of my time.

 

[Ark68]

For anyone that might be following ... I messed around with my limited knowledge of VBA and came up with this. It's not pretty, I'm certainthere is a more efficient and accurate way of doing it. It doesn't do 100% of what I set out to do, and it's only been tested with a static set of data. Not sure if it will still be effective in real time.

Sub createservice2()
    Dim stime As Variant, hjl As Date, hjh As Date
    Dim etime As Date
    Dim ctr As String, ctf As String
    Dim dt As Date
    'Dim wb_tw As Workbook
    'Dim ws_fmatemp As Worksheet
    'Dim ws_master As Worksheet
    Dim stcrew As String
    Dim altcol2 As Double
    Dim ef As Boolean 'exit for trigger
   
    'Set wb_tw = ThisWorkbook
    'Set ws_fmatemp = wb_tw.Worksheets("FMA_Templates")
    'Set ws_master = wb_tw.Worksheets("Master")
    'RowStart = 778
    'RowEnd = 793
    'dt = 44779
    'stime = dt + 0.4583333333   '11:00A
    'etime = dt + 0.9375   '10:30P
    'ctr = "BP"
   
    With ws_fmatemp
        'create roster
        .Range("AW" & RowStart & ":BC" & RowEnd).ClearContents
        x = RowStart
        sdr = RowStart 'list destination
        ef = False

        For p = 10 To 38
            If ws_master.Cells(p, 20) <> "" Then
                .Cells(x, "AW") = Left(ws_master.Cells(p, 19), 3)
                .Cells(x, "AX") = dt + ws_master.Cells(p, 20)
                .Cells(x, "AY") = dt + ws_master.Cells(p, 21)
                If .Cells(x, "AY") < .Cells(x, "AX") Then .Cells(x, "AY") = dt + ws_master.Cells(p, 21) + 1

                'determine combined crew period (1 & 2)
                If .Cells(x, "AW") = .Cells(x - 1, "AW") Then
                    hjl = WorksheetFunction.Min(.Range("AX" & x & ":AX" & x - 1))
                    hjh = WorksheetFunction.Max(.Range("AY" & x & ":AY" & x - 1))
                    .Cells(x - 1, "AX") = hjl
                    .Cells(x - 1, "AY") = hjh
                    .Range("AW" & x & ":AY" & x).ClearContents
                    x = x - 1
                End If
                x = x + 1
            End If
        Next p

        pdur = DateDiff("n", stime, etime) / 60
        rw1 = .Range(.Cells(RowStart, "AW"), .Cells(RowEnd, "AW")).Find("*", , xlValues, , xlRows, xlPrevious).Row 'Address(0, 0)
        x = RowStart
        'hjl = ""
        For p = RowStart To rw1
            If Left(.Cells(p, "AW"), 2) = ctr Then
                hjl = .Cells(p, "AX")
                hjh = DateAdd("n", -30, .Cells(p, "AY"))
                shiftdur = DateDiff("n", hjl, hjh) / 60
                If hjl <= stime Then 'they can start
                    stcrew = .Cells(p, "AW")
                    .Cells(x, "AZ") = stcrew
                    .Cells(x, "BA") = Format(stime, "h:mmA/P")
                    If hjh <= etime Then
                        .Cells(x, "BB") = Format(hjh, "h:mmA/P")
                    End If
                    If hjh >= etime Then
                        MsgBox "This crew covers it all!"
                        .Cells(x, "BB") = etime
                        ef = True
                    Else
                        gg = DateDiff("n", hjh, etime) / 60
                        stime = hjh
                        'Next p
                    End If
                End If
                x = x + 1
            Else 'use alternates
                altcol = Worksheets("LISTS2").Range("AG3:AL3").Find(ctr).Row + 31
                srw = 4
                lrw = Worksheets("LISTS2").Cells(Worksheets("LISTS2").Rows.Count, altcol).End(xlUp).Row
                For y = srw To lrw
                    ctf = Worksheets("LISTS2").Cells(y, altcol)
                    Debug.Print "Alternate to find: " & ctf
                    For Z = RowStart To rw1
                        Debug.Print "Staff list value: " & Left(.Cells(Z, "AW"), 2)
                        If Left(.Cells(Z, "AW"), 2) = ctf Then
                            hjl = .Cells(Z, "AX")
                            hjh = DateAdd("n", -30, .Cells(Z, "AY"))
                            shiftdur = DateDiff("n", hjl, hjh) / 60
                            If hjl <= stime And hjh >= etime Then 'they can start
                                stcrew = .Cells(Z, "AW")
                                .Cells(x, "AZ") = stcrew
                                .Cells(x, "BA") = Format(stime, "h:mmA/P")
                                If hjh <= etime Then
                                    .Cells(x, "BB") = Format(hjh, "h:mmA/P")
                                End If
                                If hjh >= etime Then
                                    MsgBox "This crew covers it all!"
                                    .Cells(x, "BB") = etime
                                    ef = True
                                Else
                                    gg = DateDiff("n", hjh, etime) / 60
                                    stime = hjh
                                End If
                                x = x + 1
                            End If
                        End If
                        If ef = True Then Exit For
                    Next Z
                   
                    If ef = True Then Exit For
                 Next y
            End If
            If ef = True Then Exit For
        Next p
    End With
End Sub