Calculate the "true" duration of up/down times accounting for gaps and overlaps

=GetTrueDuration([@WidgetID],[@[Start Time]],[@[End Time]])

Option Explicit

Public Function GetTrueDuration(rngIdentifier As Range, rngStartDates As Range, rngEndDates As Range) As Variant

    On Error GoTo ErrorHandler
    
    Dim lso As ListObject
    Dim intTableOffset As Integer
    Dim varIdentifier As Variant
    Dim strIdentifier As String
    Dim strIdentifierColumnName As String
    Dim strStartDatesColumnName As String
    Dim strEndDatesColumnName As String
    Dim arrData As Variant
    Dim arrNonContiguousNonOverlapping As Variant
    Dim result As Variant
    Dim i As Long
    
    Set lso = rngIdentifier.ListObject
    
    If lso Is Nothing Then
        result = "Range must be in table form"
        GoTo Exit_GetTrueDuration
    End If
    
    intTableOffset = (lso.Range.Resize(, 1).Column - 1)
    varIdentifier = rngIdentifier.Value
    strIdentifier = IIf(TypeName(varIdentifier) = "String", Chr(34) & CStr(varIdentifier) & Chr(34), CStr(varIdentifier))
    strIdentifierColumnName = lso.ListColumns(rngIdentifier.Column - intTableOffset).Name
    strStartDatesColumnName = lso.ListColumns(rngStartDates.Column - intTableOffset).Name
    strEndDatesColumnName = lso.ListColumns(rngEndDates.Column - intTableOffset).Name
    
    arrData = Evaluate("=FILTER(CHOOSE({1,2}," & lso.Name & "[" & strStartDatesColumnName & "]," & lso.Name & "[" & strEndDatesColumnName & "]), " & lso.Name & "[" & strIdentifierColumnName & "]=" & strIdentifier & ")")
    arrData = Application.WorksheetFunction.Transpose(arrData)
    Call ReduceArray(arrData)
    
    result = 0
    For i = LBound(arrData, 2) To UBound(arrData, 2)
        result = result + CDbl(arrData(2, i) - arrData(1, i))
    Next i

Exit_GetTrueDuration:
    GetTrueDuration = result
    
ErrorHandler:
    result = "Formula Error"

End Function

Private Function ReduceArray(arrToReduce As Variant) As Variant

    On Error GoTo ErrorHandler

    Dim blnChanged As Boolean
    Dim i As Long
    Dim j As Long
    Dim result As Variant

    If IsEmpty(arrToReduce) Then GoTo Exit_ReduceArray

    blnChanged = False

    For i = LBound(arrToReduce, 2) To UBound(arrToReduce, 2)
        For j = i + 1 To UBound(arrToReduce, 2)
            ' 1) Is the focus period (i) wholly contained within the comparable period (j)?
            If arrToReduce(1, i) >= arrToReduce(1, j) And arrToReduce(2, i) <= arrToReduce(2, j) Then
                ' Yes, period (i) is wholly contained within period (j) - remove period (i) from the array (it is "covered" by period (j) already)
                Call DeleteElementAt(i, arrToReduce)
                blnChanged = True
            ' 2) Does the focus period (i) wholly contain the comparable period (j)?
            ElseIf arrToReduce(1, i) <= arrToReduce(1, j) And arrToReduce(2, i) >= arrToReduce(2, j) Then
                ' Yes, period (j) is wholly contained within period (i) - remove period (j) from the array (it is "covered" by period (i) already)
                Call DeleteElementAt(j, arrToReduce)
                blnChanged = True
            ' 3) Does the focus period (i) overlap with the comparable period (j) on the start side?
            ElseIf arrToReduce(1, i) < arrToReduce(1, j) And arrToReduce(2, i) >= arrToReduce(1, j) And arrToReduce(2, i) < arrToReduce(2, j) Then
                ' Yes, period (i) overlaps with period (j) on the start side - adopt the earlier start (i) into period (j) and remove period (i) (now "covered" by period (j))
                arrToReduce(1, j) = arrToReduce(1, i)
                Call DeleteElementAt(i, arrToReduce)
                blnChanged = True
            ' 4) Does the focus period (i) overlap with the comparable period (j) on the end side?
            ElseIf arrToReduce(1, i) < arrToReduce(2, j) And arrToReduce(2, i) >= arrToReduce(2, j) And arrToReduce(1, i) > arrToReduce(1, j) Then
                ' Yes, period (i) overlaps with period (j) on the end side - adopt the later end (i) into period (j) and remove period (i) (now "covered" by period (j))
                arrToReduce(2, j) = arrToReduce(2, i)
                Call DeleteElementAt(i, arrToReduce)
                blnChanged = True
            End If
            If blnChanged Then Exit For
        Next j
        If blnChanged Then Exit For
    Next i
    
    If blnChanged Then
        ' Repeat recursively until no changes are made to the array - thus leaving a list of distinct, non-overlapping, non-contiguous periods
        ReduceArray = ReduceArray(arrToReduce)
    Else
        ' No changes detected - bubble back up to previous iteration / return final reduced array to main subroutine
        result = arrToReduce
    End If

Exit_ReduceArray:
    ReduceArray = result
    Exit Function
    
ErrorHandler:
    result = Nothing
    Resume Exit_ReduceArray
    
End Function

Public Sub DeleteElementAt(ByVal index As Integer, ByRef arr As Variant)
    Dim i As Integer
    Dim j As Integer
    ' Move all element back one position
    For i = index + 1 To UBound(arr, 2)
        For j = LBound(arr, 1) To UBound(arr, 1)
            arr(j, i - 1) = arr(j, i)
        Next j
    Next
    ' Shrink the array by one, removing the last one
    ReDim Preserve arr(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(arr, 2) - 1)
End Sub