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

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

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`

“声明变量
Dim timeStart（）作为案例的日期开始时间
Dim TIMEND（）作为案例的日期结束时间
Dim ovlpStart（）作为案例重叠区域的双“开始时间”
Dim ovlpEnd（）作为案例重叠区域的双“结束时间”
Dim totalRows As Long“案例总数”`
'检索行数
totalRows=工作表函数.CountA（列（1））
'将EXCEL工作表中的列数据存储到数组中
ReDim timeStart（1到totalRows）
ReDim timeEnd（1到totalRows）
ReDim ovlpStart（1到总计行）
ReDim ovlpEnd（1到总计行）
'用电子表格中的数据填充数组
对于i=2到总计行
timeStart（i）=单元格（i，3）.值
timeEnd（i）=单元格（i，4）.值
'初始化ovlpStart和ovlpEnd
ovlpStart（i）=1
ovlpEnd（i）=0
下一个
'在“并发”列中填入所有零以开始
对于i=2到总计行
单元格（i，6）。Value=“0”
下一个
'搜索并发时间间隔
对于i=2到总计行
对于j=（i+1）到totalRows
'检查时间是否与案例i和j重叠
Dimp diff1为双精度
Dimp diff2为双精度
diff1=时间结束（j）-时间开始（i）
diff2=时间结束（i）-时间开始（j）
如果diff1>0和diff2>0，则
'在电子表格中将案例i和j标记为并发
单元格（i，6）。Value=“1”
单元格（j，6）。Value=“1”
'确定重叠开始和结束b/w情况i和j，存储为x和y
将x调为双精度
双色
如果timeStart（i）>timeStart（j），则
x=时间开始（i）
其他的
x=时间起点（j）
如果结束
如果timeEnd（i）ovlpEnd（i），则
ovlpEnd（i）=y
如果结束
如果y>ovlpEnd（j），则
ovlpEnd（j）=y
如果结束
如果结束
下一个
下一个
'确定重叠的持续时间，打印到电子表格上
Dim ovlpDuration为双精度
对于i=2到总计行
ovlpDuration=ovlpEnd（i）-ovlpStart（i）
如果不是，那么
单元格（i，7）。值=ovlpDuration
其他的
单元格（i，7）。值=0
如果结束
下一个`

我不能说我完全遵循了你的逻辑。例如，我不明白为什么1和4不重叠

然而，看起来好像你只需要取比较的开始时间中的较晚者和比较的结束时间中的较早者，然后从前者中减去后者。如果结果为正，则存在重叠，因此在循环中聚合结果

我假设您的时间值是

时间

格式（即hh:mm），因此

加倍

下面的代码对您的范围进行了硬编码，因此您需要根据需要对其进行调整，但至少您可以看到启动的逻辑：

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

Dim t启动为双精度
暗淡的有双重的倾向
双色调暗tDiff
Dim v作为变体
作为整数的Dim i
作为整数的Dim j
变光输出（1至5，1至2）作为变型
v=表1.范围（“A2:C6”）.值2
对于i=1到5
对于j=i+1到5
tStart=IIf（v（i，2）>v（j，2），v（i，2），v（j，2））
倾向=IIf（v（i，3）0，则
输出（i，1）=输出（i，1）+tDiff
输出（j，1）=输出（j，1）+tDiff
输出（i，2）=输出（i，2）&i&“&j&”
输出（j，2）=输出（j，2）&i&“&j&”
如果结束
下一个
下一个
表1.范围（“B9:C13”）。值=输出

具有可用的。如果将小时视为虚拟工作表上的虚拟行，并计算它们之间可能相交的行数，则可以使用该整数作为函数中的小时间隔

与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

Sub-hours（）
暗i为长，j为长，ohrs为双
带工作表（“表7”）
对于i=2到.Cells（Rows.Count，“C”）.End（xlUp）.Row
ohrs=0
对于j=2到.单元格（Rows.Count，“C”）.End（xlUp）.Row
如果j i不相交（范围（小时（.Cells（i，“B”）.Value2）&“&Hour（.Cells（i，“C”）.Value2））_
范围（小时（.Cells（j，“B”）.Value2）和：“&Hour（.Cells（j，“C”）.Value2））则为零
ohrs=ohrs+时间序列（相交（范围（小时（.Cells（i，“B”）.Value2）和“：”&Hour（.Cells（i，“C”）.Value2））_
范围（小时（.j，“B”）。数值2和“&”小时（.C
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