VBA 20 minute time interval looping

[Kariba]

Hi, I have a table below which are timed tasks. Each task takes 20 minutes max. I need to group tasks that are at least 20 minutes apart.

I have the following VBA which works to assign the first tasks to "Person 1", but can't get it to loop past that to allocate the next unassigned task to "Person 2", "Person 3" etc. A person cannot complete more than 6 tasks in a row.

Thanks

Book1
	G	H	I
1	G	H	Expected
2	01/01/2024 06:00	1	1
3	01/01/2024 06:10		2
4	01/01/2024 06:15		3
5	01/01/2024 06:20	1	1
6	01/01/2024 06:25		4
7	01/01/2024 06:25		5
8	01/01/2024 06:30		2
9	01/01/2024 06:30		6
10	01/01/2024 06:40	1	1
11	01/01/2024 06:40		3
12	01/01/2024 06:45		4
13	01/01/2024 06:55		2
14	01/01/2024 06:55		5
15	01/01/2024 06:55		6
16	01/01/2024 06:55		7
17	01/01/2024 07:00	1	1
18	01/01/2024 07:00		3
Sheet1

Sub MarkCells()
Dim ws As Worksheet
Set ws = ActiveSheet

Dim prevTime As Date
Dim i As Long

ws.Range("H2").Value = 1
prevTime = ws.Range("G2").Value

For i = 3 To 19
If IsEmpty(ws.Cells(i, "H")) Then
If ws.Cells(i, "G").Value - prevTime >= TimeSerial(0, 20, 0) Then
ws.Cells(i, "H").Value = 1
prevTime = ws.Cells(i, "G").Value
End If
End If
Next i
End Sub

 

[Kaper]

Try such code:

Sub MarkCells2()
Dim lr As Long, i As Long, j As Long, taskforfirst As Long
Dim lasttask() As Date, timetable As Variant, outputtable As Variant

'initialize
lr = Cells(Rows.Count, "G").End(xlUp).Row
timetable = Range("G2:G" & lr).Value
Range("H2:H" & lr).ClearContents
ReDim outputtable(1 To lr - 1, 1 To 1)
ReDim lasttask(1 To lr - 1)
For i = 1 To lr - 1
  lasttask(i) = timetable(1, 1) - TimeSerial(0, 1, 0)
Next i

'loop through tasks
For j = 1 To lr - 1
' try to assign to lowest available number
  For i = 1 To lr - 1
' the correction  is needed here because date/time representation is in double numbers, so for
' instance 06:40:00 + TimeSerial(0, 20, 0) is not <= 07:00:00 (shall be equal)
    If Not (i = 1 And taskforfirst = 6) And lasttask(i) <= timetable(j, 1) + TimeSerial(0, 0, 1) Then
      If i = 1 Then
        taskforfirst = taskforfirst + 1
      Else
        taskforfirst = 0
      End If
      outputtable(j, 1) = i
      lasttask(i) = timetable(j, 1) + TimeSerial(0, 20, 0)
      Exit For
    End If
  Next i
  Debug.Print timetable(j, 1), i, lasttask(1)
Next j
Range("H2:H" & lr).Value = outputtable
End Sub

Note that after a possible sequence o 6 assignments of Person 1, there will be person 2. But as all tasks are 20 minutes long, then next task can be again assigned to person 1 because it is not next one in the row. So there is a need to control only tasks in the row for first person.

01.01.2024 07:00

01.01.2024 07:20

01.01.2024 07:40

01.01.2024 08:00

01.01.2024 08:20

01.01.2024 08:40

01.01.2024 09:00 - this one for person 2

01.01.2024 09:20

01.01.2024 09:40

01.01.2024 10:00

01.01.2024 10:20

01.01.2024 10:40

01.01.2024 11:00

01.01.2024 11:20 and after next 6 in row for person 1 again person 2