计算非连续重叠时间间隔的持续时间

我正在计算多个事件之间的总重叠时间。 每个事件可以与任何安排中的多个其他事件重叠。 我需要计算任何单个事件与任何其他事件重叠的总时间。 我有这样的数据。

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中做到这一点。 我现在的主要问题是find总结不连续重叠的方法，例如事件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应用程序对象具有可用的相交方法 。 如果将小时视为假想工作表上的虚数行，并计算它们之间可能相交的rows.count，则可以使用该整数作为TimeSerial函数中的小时间隔。

与相交松散重叠

 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 

为了避免重复一个时间段到下一个时间段的重叠时间，build立一个假想行相交的联合 。 联盟可以是不连续的范围，所以我们需要循环访问Range.Areas属性来实现Range.Rows属性的正确计数。

与相交和联盟严格重叠

 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格式（ Time ：毫米），因此Doubles 。

下面的代码硬编码你的范围，所以你需要调整，作为西装，但至less你可以看到逻辑，让你去：

 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