Добавьте ниже в новый модуль в редакторе VBA ...
Public Sub SplitTime()
Dim rngCells As Range, lngRow As Long, lngCol As Long, lngWriteRow As Long, i As Long
Dim objDestSheet As Worksheet, objContainer As Scripting.Dictionary, objBreak As Scripting.Dictionary
Dim strPerson As String, strCode As String, strThisPerson As String, bFound As Boolean
Dim x As Long, arrBreak(), lngContainerRow As Long, lngIndexToZero As Long, lngBreakRow As Long
Dim tmStart, tmEnd, tmBreakStart, tmBreakEnd, tmThisBreakStart, tmThisBreakEnd
Set objContainer = New Scripting.Dictionary
Set objBreak = New Scripting.Dictionary
Set rngCells = Selection
Set objDestSheet = Worksheets("Exploded")
objDestSheet.Cells.Clear
lngWriteRow = 1
With rngCells
' Copy the header to the destination worksheet
rngCells.EntireRow(1).Copy objDestSheet.Range("A1")
' Process each person first and foremost.
' We're going to assume that the data isn't sorted, it's safer.
' Capture the rows where the "container" row exist.
' In another dictionary, capture the "break" rows.
For lngRow = 2 To .Rows.Count
strPerson = .Cells(lngRow, 1)
strCode = UCase(.Cells(lngRow, 2))
If strCode = "CONTAINER" Then
If Not objContainer.Exists(strPerson) Then
objContainer.Add strPerson, lngRow
End If
Else
If Not objBreak.Exists(strPerson) Then
objBreak.Add strPerson, Array(lngRow)
Else
arrBreak = objBreak.Item(strPerson)
ReDim Preserve arrBreak(UBound(arrBreak) + 1)
arrBreak(UBound(arrBreak)) = lngRow
objBreak.Item(strPerson) = arrBreak
End If
End If
Next
' For each person, find the "break" rows and calculate accordingly.
For i = 0 To objContainer.Count - 1
strPerson = objContainer.Keys(i)
lngContainerRow = CLng(objContainer.Item(strPerson))
tmStart = TimeValue(.Cells(lngContainerRow, 3).Text)
tmEnd = TimeValue(.Cells(lngContainerRow, 4).Text)
lngWriteRow = lngWriteRow + 1
objDestSheet.Cells(lngWriteRow, 1) = strPerson
objDestSheet.Cells(lngWriteRow, 2) = "Container"
objDestSheet.Cells(lngWriteRow, 3) = tmStart
arrBreak = objBreak.Item(strPerson)
Do While True
tmBreakStart = ""
bFound = False
' Get the lowest out of the breaks.
For x = 0 To UBound(arrBreak)
lngBreakRow = CLng(arrBreak(x))
If lngBreakRow > 0 Then
bFound = True
tmThisBreakStart = TimeValue(.Cells(lngBreakRow, 3).Text)
tmThisBreakEnd = TimeValue(.Cells(lngBreakRow, 4).Text)
If tmBreakStart = "" Or tmThisBreakStart < tmBreakStart Then
lngIndexToZero = x
tmBreakStart = tmThisBreakStart
tmBreakEnd = tmThisBreakEnd
End If
End If
Next
If bFound Then
' Finish off the current row.
objDestSheet.Cells(lngWriteRow, 4) = tmBreakStart
lngWriteRow = lngWriteRow + 1
' Now write the next row with the breaks in it.
objDestSheet.Cells(lngWriteRow, 1) = strPerson
objDestSheet.Cells(lngWriteRow, 2) = "Break"
objDestSheet.Cells(lngWriteRow, 3) = tmBreakStart
objDestSheet.Cells(lngWriteRow, 4) = tmBreakEnd
lngWriteRow = lngWriteRow + 1
' Now write the next row that will form the gap filler for the container.
objDestSheet.Cells(lngWriteRow, 1) = strPerson
objDestSheet.Cells(lngWriteRow, 2) = "Container"
objDestSheet.Cells(lngWriteRow, 3) = tmBreakEnd
arrBreak(lngIndexToZero) = 0
Else
' We've reached the end for that person.
objDestSheet.Cells(lngWriteRow, 4) = tmEnd
Exit Do
End If
Loop
Next
End With
End Sub
... несколько предостережений.
- Перерывы не могут заканчиваться подряд. то есть вы не можете делать перерыв с 15:00 до 16:00, а затем делать перерыв сразу после 16:00 до 17:00. Это не имеет смысла, когда вы думаете об этом, поэтому, если требуется, этот перерыв следует указывать как с 15:00 до 17:00. Если у вас есть конец в конец, он сломается.
- Чтобы убедиться, что это работает, обязательно отформатируйте ваши временные ячейки как время (
[$-409]h:mm AM/PM;@)
- Данные не нужно сортировать, они будут работать независимо от того, на самом деле, вы можете видеть на изображении ниже, что я фактически вставил разрыв для человека 1 ниже, и он все еще дает правильный результат.
- Человек не может начинать или заканчивать на перерыве. Опять же, я полагаю, что в любом случае это не имеет смысла, поэтому я не принял это во внимание.
Не думаю, что вам нужно что-то еще знать.
Чтобы сделать это, добавьте в свою книгу новый лист с именем Разобранный , выберите весь набор ячеек и запустите макрос. Выходные данные будут на листе «В разобранном виде».
Я надеюсь, что это работает для вас так же, как и для меня. Если ваш набор данных так же прост, как и ожидалось, он должен идти.