Size of union of date intervals - excel

1
votes

I have an Excel sheet with start and end dates for a large amount of projects/activities (approx 10,000). Some of these projects are overlapping in time and some are not. I would then like to count how many total days has at least one project going on.

Ex.:

  • Project A Start: jan 1. 2013 - End: jan 3. 2013
  • Project B Start: jan 2. 2013 - End: jan 4. 2013
  • Project C Start: jan 6. 2013 - End: jan 7. 2013

Days in january with at least one project currently active: 1,2,3,4,6,7. Thus the total number of such days is 6.

Coming from a mathematical background I'd make a Union of the date ranges and meassure it's size. However no such standard function seems available in VBA unless the intervals are cell ranges and even then it will count overlapping ones twice. Any ideas for a clean/fast solution? (Dates are in standard excel format in my sheet).

2
vbaexcel
In which columns are your start and stop dates ? – Gary's Student
Currently start dates in column C & end dates in column D but they can be put anywhere. – AsbjornB

2 Answers

1
votes

Here's a formula approach:

=SUMPRODUCT(GESTEP(COUNTIFS(C1:C3,"<="&ROW(INDIRECT(MIN(C1:C3)&":"&MAX(D1:D3))),D1:D3,">="&ROW(INDIRECT(MIN(C1:C3)&":"&MAX(D1:D3)))),1))

and VBA equivalent user-defined function:

Function DateCount(StartDates, EndDates) As Long

Dim DateRange, DateFreq
With Application
    DateRange = .Evaluate("ROW(" & .Min(StartDates) & ":" & .Max(EndDates) & ")")
    DateFreq = .CountIfs(StartDates, .Text(DateRange, """<=""0"), EndDates, .Text(DateRange, """>=""0"))
    DateCount = .Sum(.GeStep(DateFreq, 1))
End With

End Function
1
votes

Consider this:

Sub CountDays()
    Dim wf As WorksheetFunction, col As Collection
    Set wf = Application.WorksheetFunction
    Set col = New Collection
    Dim StartDates As Range, EndDates As Range
    Dim d1 As Date, d2 As Date, d As Date
    Dim K As Long
    Set StartDates = Range("C2:C100")
    Set EndDates = Range("D2:D100")
    d1 = wf.Min(StartDates)
    d2 = wf.Max(EndDates)
    For d = d1 To d2
        For K = 2 To 100
            If d >= Cells(K, "C") And d <= Cells(K, "D") Then
                On Error Resume Next
                col.Add d, CStr(d)
                On Error GoTo 0
            End If
        Next K
    Next d
    MsgBox col.Count
End Sub

We loop over the candidate dates, checking if they fit in any range. The Collection.Add method prohibits counting the same date twice.