VBA 20 minute time interval looping

Kariba

Board Regular
Joined
Mar 15, 2023
Messages
59
Office Version
  1. 365
Platform
  1. Windows
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
GHI
1GHExpected
201/01/2024 06:0011
301/01/2024 06:102
401/01/2024 06:153
501/01/2024 06:2011
601/01/2024 06:254
701/01/2024 06:255
801/01/2024 06:302
901/01/2024 06:306
1001/01/2024 06:4011
1101/01/2024 06:403
1201/01/2024 06:454
1301/01/2024 06:552
1401/01/2024 06:555
1501/01/2024 06:556
1601/01/2024 06:557
1701/01/2024 07:0011
1801/01/2024 07:003
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
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Try such code:
VBA 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
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

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