非連続オーバーラップ時間間隔の計算時間

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の計算に（1,4）の重複を含めなかったからです。出力には、オーバーラップ期間が最も長くなります。

私が使用しているコードの一部です。今は、複数のイベント間の最長連続オーバーラップを計算します。それは不連続な重なりを合計しません。

'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を持っています。想像上のワークシート上の時間を虚数行として扱い、それらの間の可能な交差点の行数を計算する場合は、その整数をTimeSerial関数の時間間隔として使用できます。次の1つの期間からオーバーラップ時間の繰り返しを避けるするように交差

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.Rowsプロパティの正確な数を達成するには、Range.Areas propertyを循環させる必要があります。交差し、連合

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