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＆amp; 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

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

2 个答案: