Excel VBA: copy and divide rows based on date/time criteria

Question

I am trying to transform a file with a log of operations in a three-shift production environment to be able to group them by shifts (const 7-15, 15-23, 23-7), i.e. if both the start date/time and the end date/time of the record are not within the same shift then duplicate the row below and change the original end date/time and duplicated end date/time to the corresponding shift end.

Event   Start date/time    End date/time      Shift Start    Shift End
A       18/05/2017 4:30    18/05/2017 11:45   Mid (23-7)     Day (7-15)

transforming to:

Event   Start date/time    End date/time      Shift Start    Shift End
A       18/05/2017 4:30    18/05/2017 7:00    Mid (23-7)     Mid (23-7)
A       18/05/2017 7:00    18/05/2017 11:45   Day (7-15)     Day (7-15)

---

Unfortunately I am not good enough with VBA, so at the beginning I was trying to solve that using solely excel formulas, and added a column that shows how many shifts the event lasted (what is equal to the X number of rows that have to be doubled), that may be helpful with iterations.

Event    Start date/time    End date/time     Shift Start    Shift End    X
A        18/05/2017 4:30    18/05/2017 23:30  Mid (23-7)     Mid (23-7)   3

Logic behind:

Event    Start date/time    End date/time     Shift Start    Shift End    X
A        18/05/2017 4:30    18/05/2017 7:00   Mid (23-7)     Mid (23-7)   ""
A        18/05/2017 7:00    18/05/2017 23:30  Day (7-15)     Mid (23-7)   2

expected result:

Event    Start date/time    End date/time     Shift Start    Shift End    X
A        18/05/2017 4:30    18/05/2017 7:00   Mid (23-7)     Mid (23-7)   ""
A        18/05/2017 7:00    18/05/2017 15:00  Day (7-15)     Day (7-15)   ""
A        18/05/2017 15:00   18/05/2017 23:00  Aft (15-23)    Aft (15-23)  ""
A        18/05/2017 23:00   18/05/2017 23:30  Mid (23-7)     Mid (23-7)   ""

I’ve been trying to solve that for hours sourcing the internet, and eventually I have only been able to duplicate the row X-number of times below leaving column F blank, but I feel like it’s a dead end. Any assistance would be appreciated!

Thanks!

EDIT

Sub duplicate()
Dim lngRow As Long, copyRows As Integer

Application.ScreenUpdating = False
lngRow = 2 '1. header
Do Until IsEmpty(Range("A" & lngRow))
    If Range("F" & lngRow).Value >= 1 Then 'check if the row should be duplicate
        copyRows = Range("F" & lngRow).Value
        Range("F" & lngRow + 1 & ":F" & lngRow + copyRows).EntireRow.Insert
        Range("A" & lngRow & ":F" & (lngRow + copyRows)).FillDown 'was just testing the code. here I think I should work on cells and defined const. do I need an array to solve that problem?
        Range("F" & lngRow & ":F" & (lngRow + copyRows)).Value = ""
        lngRow = lngRow + copyRows
    End If
    lngRow = lngRow + 1
Loop
End Sub

EDIT 2 this is my first code I have ever written, sorry for any mistakes. I know it's not the cleanest code, but I try my best.

Sub duplicate2()
Dim lngRow As Long, copyRows As Integer

Application.ScreenUpdating = False
lngRow = 2 '1. header
Do Until IsEmpty(Range("A" & lngRow))
    If Range("F" & lngRow).Value >= 1 Then 'check if the row should be duplicated
        copyRows = Range("F" & lngRow).Value 'ok
        Range("F" & lngRow + 1 & ":F" & lngRow + 1).EntireRow.Insert 'insert a row below
        Range("F" & lngRow + 1 & ":F" & lngRow + 1).Value = copyRows - 1 'decrease X by 1
        Range("F" & lngRow & ":F" & lngRow).Value = "" 'clean original X
        Range("A" & lngRow + 1 & ":E" & lngRow + 1).FillDown 'duplicate row

        'here I should work on cells and defined const. do I need an array to solve that problem?

    End If
    lngRow = lngRow + 1
Loop
End Sub

---

Sub duplicate()
Dim lngRow As Long, copyRows As Integer

Application.ScreenUpdating = False
lngRow = 2 '1. header
Do Until IsEmpty(Range("A" & lngRow))
    If Range("F" & lngRow).Value >= 1 Then 'check if the row should be duplicate
        copyRows = Range("F" & lngRow).Value
        Range("F" & lngRow + 1 & ":F" & lngRow + copyRows).EntireRow.Insert
        Range("A" & lngRow & ":F" & (lngRow + copyRows)).FillDown 'was just testing the code. here I think I should work on cells and defined const. do I need an array to solve that problem?
        Range("F" & lngRow & ":F" & (lngRow + copyRows)).Value = ""
        lngRow = lngRow + copyRows
    End If
    lngRow = lngRow + 1
Loop
End Sub

Answer 1

You can try this macro to split the rows by shift. Uses only columns A-C without using your additional helper columns. It can handles durations that can span many days, because it handles the dates and calculates the shifts precisely using a dedicated function (see the utility function shifEnd below).

Sub SplitShifts()
  Application.ScreenUpdating = False: Application.EnableEvents = False
  On Error GoTo Cleanup

  Dim r As Range: Set r = Sheet1.Range("A2:F2")
  Do Until Len(Trim(r(1))) = 0 ' loop until row is empty
    If shiftEnd(r(2)) >= r(3) Then
      Set r = r.Offset(1) ' no split needed, next row
    Else ' insert new row and split shifts
      r.Copy: r.Insert Shift:=xlDown
      r(2) = shiftEnd(r(2))
      r(0, 3) = r(2)
    End If
  Loop

Cleanup:
  Application.ScreenUpdating = True: Application.EnableEvents = True: Application.CutCopyMode = False
End Sub

Function shiftEnd(ByVal d As Date) As Date
  Select Case Hour(d)
    Case 0 To 6: shiftEnd = Int(d) + TimeSerial(7, 0, 0)
    Case 7 To 14: shiftEnd = Int(d) + TimeSerial(15, 0, 0)
    Case 15 To 22: shiftEnd = Int(d) + TimeSerial(23, 0, 0)
    Case 23: shiftEnd = Int(d) + 1 + TimeSerial(7, 0, 0) ' Next day 7:00
  End Select
End Function

---

Testing

Event   Start date      End date
A       5/18/17 4:30    5/18/17 21:18
B       5/20/17 18:54   5/22/17 2:06
C       5/22/17 11:42   5/23/17 6:54
D       5/25/17 16:30   5/26/17 6:54
E       5/26/17 4:30    5/26/17 18:54
F       5/27/17 4:30    5/28/17 14:06
G       5/30/17 16:30   5/31/17 23:42