Вычислить продолжительность непрерывных интервалов перекрытия

Question

Я пытаюсь вычислить общую продолжительность перекрытия между несколькими событиями. Каждое событие может пересекаться с несколькими другими событиями в любой компоновке. Мне нужно рассчитать общий промежуток времени, когда какое-либо одно событие перекрывается с любым другим событием. Данные, которые у меня есть, выглядят следующим образом.

event timeStart timeEnd 
1  15:00  22:00 
2  12:00  18:00 
3  20:00  23:00 
4  16:00  17:00 
5  10:00  14:00 

Output: 

event timeOverlap 
1  05:00  '03:00 (1,2) + 02:00 (1,3) 
2  04:00  '03:00 (1,2) + 01:00 (2,4) 
3  02:00  '02:00 (1,3) 
4  01:00  '01:00 (2,4) 
5  02:00  '02:00 (2,5) 

Я пытаюсь сделать это в Excel VBA. Моя основная проблема прямо сейчас заключается в том, чтобы найти способ суммирования прерывистых перекрытий, например. событие 1 или событие 2. Любая помощь будет оценена по достоинству.

Редактировать: Чтобы уточнить, я хотел бы избежать двойного подсчета, поэтому я не включил перекрытие между (1,4) в вычислении для события 1. На выходе должна отображаться сумма перекрытий, которые приведет к наибольшей продолжительности перекрытия.

Вот часть кода, который я использую. Сейчас он вычисляет самое длинное непрерывное перекрытие между несколькими событиями. Он не суммирует прерывистые перекрытия.

'DECLARE VARIABLES 
Dim timeStart() As Date 'start times of cases 
Dim timeEnd() As Date  'end times of cases 
Dim ovlpStart() As Double 'start times of overlap regions for cases 
Dim ovlpEnd() As Double  'end times of overlap regions for cases 
Dim totalRows As Long  'total number of cases` 

'RETRIEVE NUMBER OF ROWS 
totalRows = WorksheetFunction.CountA(Columns(1)) 

'STORE COLUMN DATA FROM EXCEL SHEET INTO ARRAYS 
ReDim timeStart(1 To totalRows) 
ReDim timeEnd(1 To totalRows) 
ReDim ovlpStart(1 To totalRows) 
ReDim ovlpEnd(1 To totalRows) 

'FILL IN ARRAYS WITH DATA FROM SPREADSHEET 
For i = 2 To totalRows 
    timeStart(i) = Cells(i, 3).Value 
    timeEnd(i) = Cells(i, 4).Value 

    'Initialize ovlpStart and ovlpEnd 
    ovlpStart(i) = 1 
    ovlpEnd(i) = 0 
Next 

'FILL IN CONCURRENCE COLUMN WITH ALL ZEROS TO START 
For i = 2 To totalRows 
    Cells(i, 6).Value = "0" 
Next 

'SEARCH FOR CONCURRENT TIME INTERVALS 
For i = 2 To totalRows 
    For j = (i + 1) To totalRows 

      'Check if the times overlap b/w cases i and j 
      Dim diff1 As Double 
      Dim diff2 As Double 
      diff1 = timeEnd(j) - timeStart(i) 
      diff2 = timeEnd(i) - timeStart(j) 
      If diff1 > 0 And diff2 > 0 Then 

       'Mark cases i and j as concurrent in spreadsheet 
       Cells(i, 6).Value = "1" 
       Cells(j, 6).Value = "1" 

       'Determine overlap start and end b/w cases i and j, store as x and y 
       Dim x As Double 
       Dim y As Double 
       If timeStart(i) > timeStart(j) Then 
        x = timeStart(i) 
       Else 
        x = timeStart(j) 
       End If 
       If timeEnd(i) < timeEnd(j) Then 
        y = timeEnd(i) 
       Else 
        y = timeEnd(j) 
       End If 

        'Update ovlpStart and ovlpEnd values for cases i and j if overlap region has increased for either 
        If x < ovlpStart(i) Then 
         ovlpStart(i) = x 
        End If 
        If x < ovlpStart(j) Then 
         ovlpStart(j) = x 
        End If 
        If y > ovlpEnd(i) Then 
         ovlpEnd(i) = y 
        End If 
        If y > ovlpEnd(j) Then 
         ovlpEnd(j) = y 
        End If 
       End If 

    Next 
Next 

'DETERMINE DURATION OF OVERLAP, PRINT ONTO SPREADSHEET 
Dim ovlpDuration As Double 
For i = 2 To totalRows 
    ovlpDuration = ovlpEnd(i) - ovlpStart(i) 
    If Not ovlpDuration Then 
     Cells(i, 7).Value = ovlpDuration 
    Else 
     Cells(i, 7).Value = 0 
    End If 
Next` 

Answer 1

Excel Application object имеет Intersect method доступны. Если вы рассматриваете часы как воображаемые строки на воображаемом листе и вычисляете rows.count возможного пересечения между ними, вы можете использовать это целое число в качестве интервала часов в функции TimeSerial.

Сыпучее Перекрытие с Intersect

Sub overlapHours() 
    Dim i As Long, j As Long, ohrs As Double 
    With Worksheets("Sheet7") 
     For i = 2 To .Cells(Rows.Count, "C").End(xlUp).Row 
      ohrs = 0 
      For j = 2 To .Cells(Rows.Count, "C").End(xlUp).Row 
       If j <> i And Not Intersect(Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2)), _ 
              Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2))) Is Nothing Then 
        ohrs = ohrs + TimeSerial(Intersect(Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2)), _ 
                 Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2))).Rows.Count - 1, 0, 0) 
       End If 
      Next j 
      .Cells(i, 4).NumberFormat = "[hh]:mm" 
      .Cells(i, 4) = ohrs 
     Next i 
    End With 
End Sub 

Для того, чтобы избежать повторения раз перекрытия от одного периода времени к другому, построить Union из пересекает мнимые строки. Союзы могут быть неудовлетворительными, поэтому нам нужно пройти через Range.Areas property, чтобы достичь правильного значения свойства Range.Rows.

Строгое Перекрытие с Intersect и Союзом

Sub intersectHours() 
    Dim a As Long, i As Long, j As Long, rng As Range, ohrs As Double 
    With Worksheets("Sheet7") 
     For i = 2 To .Cells(Rows.Count, "C").End(xlUp).Row 
      ohrs = 0: Set rng = Nothing 
      For j = 2 To .Cells(Rows.Count, "C").End(xlUp).Row 
       If j <> i And Not Intersect(.Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2) - 1), _ 
              .Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2) - 1)) Is Nothing Then 
        If rng Is Nothing Then 
         Set rng = Intersect(.Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2) - 1), _ 
              .Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2) - 1)) 
        Else 
         Set rng = Union(rng, Intersect(.Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2) - 1), _ 
                 .Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2) - 1))) 
        End If 
       End If 
      Next j 
      If Not rng Is Nothing Then 
       For a = 1 To rng.Areas.Count 
        ohrs = ohrs + TimeSerial(rng.Areas(a).Rows.Count, 0, 0) 
       Next a 
      End If 
      .Cells(i, 6).NumberFormat = "[hh]:mm" 
      .Cells(i, 6) = ohrs 
     Next i 
    End With 
End Sub 

Моими результаты отличаются от тех, которые вы вывешенных для события 2, но я проследил мою логику назад и вперед и не могу видеть ошибку.

Answer 2

Не могу сказать, что я полностью следую вашей логике. Например, я не понимаю, почему 1 & 4 не перекрываются.

Однако, это выглядит так, как будто вы просто берете более поздние сравниваемые времена начала и предыдущие сравниваемые конечные времена и вычитаете последнее из первого. Если результат положительный, тогда существует перекрытие, поэтому агрегируйте результат в цикле.

Я принимаю ваши значения времени в формате Time (т.е. hh: mm) и поэтому Doubles.

Код ниже жёстко ваши диапазоны так что вам нужно настроить, что в костюмах, но, по крайней мере, вы могли бы видеть логику, чтобы ты:

Dim tStart As Double 
Dim tEnd As Double 
Dim tDiff As Double 
Dim v As Variant 
Dim i As Integer 
Dim j As Integer 
Dim output(1 To 5, 1 To 2) As Variant 

v = Sheet1.Range("A2:C6").Value2 
For i = 1 To 5 
    For j = i + 1 To 5 
     tStart = IIf(v(i, 2) > v(j, 2), v(i, 2), v(j, 2)) 
     tEnd = IIf(v(i, 3) < v(j, 3), v(i, 3), v(j, 3)) 
     tDiff = tEnd - tStart 
     If tDiff > 0 Then 
      output(i, 1) = output(i, 1) + tDiff 
      output(j, 1) = output(j, 1) + tDiff 
      output(i, 2) = output(i, 2) & i & "&" & j & " " 
      output(j, 2) = output(j, 2) & i & "&" & j & " " 
     End If 
    Next 
Next 

Sheet1.Range("B9:C13").Value = output