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

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 可用。如果您将小时数视为假想工作表上的假想行并计算它们之间可能交集的 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

为避免从一个时间段到下一个时间段重复重叠时间，请构建假想行的交叉点的Union。联合可以是不连续的范围，因此我们需要循环遍历 Range.Areas property 以正确计算 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 格式（即 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