Dauer der nicht kontinuierlichen überlappenden Zeitintervalle berechnen

Question

Ich versuche, die Gesamtdauer der Überlappung zwischen mehreren Ereignissen zu berechnen. Jedes Ereignis kann sich mit mehreren anderen Ereignissen in einer beliebigen Anordnung überschneiden. Ich muss die Gesamtzeit berechnen, in der sich ein einzelnes Ereignis mit einem anderen Ereignis überschneidet. Die Daten, die ich habe, sieht so aus.

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) 

Ich versuche dies in Excel VBA zu tun. Mein Hauptproblem besteht derzeit darin, einen Weg zu finden, diskontinuierliche Überlappungen, z. Ereignis 1 oder Ereignis 2. Jede Hilfe wäre willkommen.

Edit: Zur Verdeutlichung möchte ich Doppelzählungen vermeiden, weshalb ich die Überlappung zwischen (1,4) in der Berechnung für Ereignis 1 nicht berücksichtigt habe. Die Ausgabe sollte die Summe der Überlappungen anzeigen würde die größte Überlappungsdauer ergeben.

Hier ist ein Teil des Codes, den ich verwende. Im Moment berechnet es die längste kontinuierliche Überlappung zwischen mehreren Ereignissen. Sie fasst keine diskontinuierlichen Überlappungen zusammen.

'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

Die Excel Application object hat die Intersect method zur Verfügung. Wenn Sie die Stunden als imaginäre Zeilen auf einem imaginären Arbeitsblatt behandeln und die Zeilenanzahl eines möglichen Schnittpunkts zwischen ihnen berechnen, können Sie diese Ganzzahl als Stundenintervall in einer TimeSerial-Funktion verwenden.

lose Überlapp mit 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 

Um zu vermeiden, den Überlappungszeiten von einer Zeitperiode zur nächsten Wiederholung ein Union der intersects der imaginären Reihen aufzubauen. Verbindungen können nicht zusammenhängende Bereiche sein, daher müssen wir die Range.Areas property durchgehen, um eine korrekte Zählung der Range.Rows Eigenschaft zu erreichen.

Strenge Overlap mit Intersect und Union

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 

Meine Ergebnisse unterscheiden sich von denen, die Sie für Event gebucht 2, aber ich habe meine Logik hin und her verfolgt und kann keinen Fehler sehen.

Answer 2

Ich kann nicht sagen, ich folge völlig Ihrer Logik. Zum Beispiel sehe ich nicht, warum 1 & 4 nicht überlappen.

Es sieht jedoch so aus, als würden Sie nur die spätere der verglichenen Startzeiten und die frühere der verglichenen Endzeiten nehmen und letztere von der vorherigen subtrahieren. Wenn das Ergebnis positiv ist, gibt es eine Überlappung, so dass das Ergebnis innerhalb einer Schleife aggregiert wird.

Ich nehme an, dass Ihre Zeitwerte im Time Format sind (dh hh: mm) und daher Doubles.

Der folgende Code Hardcodes Ihre Bereiche, so dass Sie, dass wie Anzüge anpassen müssen, aber zumindest kann man die Logik sehen, um Sie gehen:

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