VBA overlapping networkdays from dates with a condition

Question

First I'm open to do this with an other angle.

I want to count the total hours of work hours estimated, see sheet2. In another sub I've calculated the total work hours (timer tot) with worksheetfunction.sum and timer FRJ/HET with worksheetfunction.sumif. This code doesn't consider overlapping days which means if the dates intersect each other it will calculate 8*2(3,4,5...) (8 hours is average workday in Norway) instead of 8 hours per workday. This will mess up the total amount of time estimated and posibly we will estimate more hours per day than 24 hours :D

I've started this code underneath which I will use to substract the total amount of time and total amout for FRJ and HET.

Code:

Sub Overlapping_WorkDays()

Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range

Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))

For Each cell_name In rng_FRJ_HET
    If cell_name = "FRJ" Then
        'Count Overlapping networkdays for FRJ
    Elseif cell_name = "HET" Then
        'Count Overlapping networkdays for HET
    End If
Next cell_name

End Sub

Sheet1 screenshot

Sheet2 screenshot

Answer 1

As far as I know there is no direct formula to get overlap dates. My approach will be different from yours.

For each unique value in rng_FRJ_HET (i.e. only FRJ and HET as per e.g.)
   Create an array with first date and last date
   Mark array index with 1 for each date in range start and end date
   Sum the array to get actual number of days
Next

So if the dates are repeated still they will mark as 1 in the array for that date. =====================Added the code=== This will do for any number of names.

Option Explicit

Dim NameList() As String

Sub Overlapping_WorkDays()
    Dim rng_FRJ_HET As Range
    Dim cell_name As Range
    Dim startDateRng As Range
    Dim endDateRng As Range
    Dim uniqueNames As Range
    Dim stDate As Variant
    Dim edDate As Variant
    Dim Dates() As Integer

    Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
    Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
    Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))

    stDate = Application.WorksheetFunction.Min(startDateRng)
    edDate = Application.WorksheetFunction.Max(endDateRng)
    ReDim NameList(0)
    NameList(0) = ""

    For Each cell_name In rng_FRJ_HET
        If IsNewName(cell_name) Then
            ReDim Dates(stDate To edDate + 1)
            MsgBox cell_name & " worked for days : " & CStr(GetDays(cell_name, Dates))
        End If
    Next cell_name

End Sub

Private Function GetDays(ByVal searchName As String, ByRef Dates() As Integer) As Integer
    Dim dt As Variant
    Dim value As String
    Dim rowIndex As Integer

    Const COL_NAME = 1
    Const COL_STDATE = 4
    Const COL_EDDATE = 5
    Const ROW_START = 8
    Const ROW_END = 19

    With Sheet1
        For rowIndex = ROW_START To ROW_END
            If searchName = .Cells(rowIndex, COL_NAME) Then
                For dt = .Cells(rowIndex, COL_STDATE).value To .Cells(rowIndex, COL_EDDATE).value
                    Dates(CLng(dt)) = 1
                Next
            End If
        Next
    End With

    GetDays = WorksheetFunction.Sum(Dates)
End Function

Private Function IsNewName(ByVal searchName As String) As Boolean
    Dim index As Integer

    For index = 0 To UBound(NameList)
        If NameList(index) = searchName Then
            IsNewName = False
            Exit Function
        End If
    Next

    ReDim Preserve NameList(0 To index)
    NameList(index) = searchName
    IsNewName = True
End Function

Answer 2

I think if I were doing this, I'd use the Collection object, as it'd save converting names and dates to index id's.

You could create a main collection of names and, for each name, a sub collection of dates whose key is Excel's date serial number. This would make it easy to store the 'used days' and you could either acquire the total day count by using the .Count property or loop through the collection to aggregate a specific Oppgave.

The code would be straight forward as shown below. You could just put this in a module:

Option Explicit

Private mNames As Collection

Public Sub RunMe()

    ReadValues

    'Get the total days count
    Debug.Print GetDayCount("FRJ")
    'Or get the days count for one Oppgave
    Debug.Print GetDayCount("FRJ", "Malfil tegning form")

End Sub

Private Sub ReadValues()
    Dim v As Variant
    Dim r As Long, d As Long
    Dim item As Variant


    Dim dates As Collection

    With Sheet1
        v = .Range(.Cells(8, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 5).Value2
    End With

    Set mNames = New Collection
    For r = 1 To UBound(v, 1)
        'Acquire the dates collection for relevant name
        Set dates = Nothing: On Error Resume Next
        Set dates = mNames(CStr(v(r, 1))): On Error GoTo 0
        'Create a new dates collection if it's a new name
        If dates Is Nothing Then
            Set dates = New Collection
            mNames.Add dates, CStr(v(r, 1))
        End If
        'Add new dates to the collection
        For d = v(r, 4) To v(r, 5)
            On Error Resume Next
            dates.Add v(r, 2), CStr(d)
            On Error GoTo 0
        Next
    Next
End Sub
Private Function GetDayCount(namv As String, Optional oppgave As String) As Long
    Dim dates As Collection
    Dim v As Variant

    Set dates = mNames(namv)

    If oppgave = vbNullString Then
        GetDayCount = dates.Count
    Else
        For Each v In dates
            If v = oppgave Then GetDayCount = GetDayCount + 1
        Next
    End If

End Function

Answer 3

All you need to do is loop through all the date ranges and count them if they haven't already been counted. A Dictionary from the Microsoft Scripting Runtime is well suited for this (you'll need to add a reference in Tools->References).

Function TotalWorkDays(Optional category As String = vbNullString) As Long
    Dim lastRow As Long

    With Sheet1
        lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row

        Dim usedDates As Scripting.Dictionary
        Set usedDates = New Scripting.Dictionary

        Dim r As Long
        'Loop through each row with date ranges.
        For r = 8 To lastRow
            Dim day As Long
            'Loop through each day.
            For day = .Cells(r, 4).Value To .Cells(r, 5).Value
                'Check to see if the day is already in the Dictionary
                'and doesn't fall on a weekend.
                If Not usedDates.Exists(day) And Weekday(day, vbMonday) < 6 _
                    And (.Cells(r, 1).Value = category Or category = vbNullString) Then
                    'Haven't encountered the day yet, so add it.
                    usedDates.Add day, vbNull
                End If
            Next day
        Next
    End With
    'Return the count of unique days.
    TotalWorkDays = usedDates.Count
End Function

Note that this will work for any arbitrary category found in column 1, or all categories combined if it isn't passed an argument. Sample usage:

Sub Usage()
    Debug.Print TotalWorkDays("HET")  'Sample data prints 55
    Debug.Print TotalWorkDays("FRJ")  'Sample data prints 69
    Debug.Print TotalWorkDays         'Sample data prints 69
End Sub

You can convert this to late bound (and skip adding the reference) by replacing these two lines...

    Dim usedDates As Scripting.Dictionary
    Set usedDates = New Scripting.Dictionary

...with:

    Dim usedDates As Object
    Set usedDates = CreateObject("Scripting.Dictionary")

Answer 4

Dictionary approach should be the fastest.

But if your data are not that big you may want to adopt a "string" approach like follows

Function CountWorkingDays(key As String) As Long
    Dim cell As Range
    Dim iDate As Date
    Dim workDates As String

    On Error GoTo ExitSub
    Application.EnableEvents = False
    With Sheet1
        With .Range("E7", .Cells(.Rows.Count, "A").End(xlUp))
            .AutoFilter field:=1, Criteria1:=key
            For Each cell In Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Columns(1))
                For iDate = cell.Offset(, 3) To cell.Offset(, 4)
                    If Weekday(iDate, vbMonday) < 6 Then
                        If InStr(workDates, cell.value & iDate) <= 0 Then workDates = workDates & cell.value & iDate
                    End If
                Next iDate
            Next cell
        End With
    End With

    CountWorkingDays = UBound(Split(workDates, key))
ExitSub:
    Sheet1.AutoFilterMode = False
    Application.EnableEvents = True
End Function

that you can use in your code as follows

sht2.Cells(2, 7) = CountWorkingDays("FRJ")
sht2.Cells(2, 8) = CountWorkingDays("HET")