VBA overlapping networkdays from dates with a condition - excel

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

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 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

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")

Answer 4

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