Public Function CalculateWeekdays(ByVal startDate As Variant, ByVal endDate As Variant, Optional ByVal includeHolidays As Boolean = False) As Variant
On Error GoTo Err_Handler
' Check if the end date is before the start date.
If endDate < startDate Then
MsgBox "End date cannot be before the start date.", vbExclamation + vbOKOnly, "Weekday Calculation"
Exit Function
End If
Dim currentDate As Date
Dim weekdays As Long
Dim holidays As Collection
' If includeHolidays is True, fetch the holidays.
If includeHolidays Then
Dim currentYear As Integer
Set holidays = New Collection
For currentYear = year(startDate) To year(endDate)
Dim yearHolidays As Collection
Set yearHolidays = GetUSHolidays(currentYear)
Dim h As Variant
For Each h In yearHolidays
' Only add the holiday to the collection if it's within the startDate and endDate range.
If h >= startDate And h <= endDate And Not ExistsInCollection(holidays, h) Then
holidays.Add h
End If
Next h
Next currentYear
End If
' Initialize the weekdays counter to 0.
weekdays = 0
' Set our iterating date to the start date.
currentDate = startDate
' Iterate through each date between start and end dates, excluding the end date.
Do While currentDate < endDate
' Check if the current date is a weekday (Monday to Friday).
If Weekday(currentDate) >= 2 And Weekday(currentDate) <= 6 Then
' If we're including holidays, check if the date is a holiday.
If includeHolidays Then
Dim isHoliday As Boolean
isHoliday = False
Dim hd As Variant
For Each hd In holidays
If hd = currentDate Then
isHoliday = True
Exit For
End If
Next hd
' If it's not a holiday, increment the weekdays count.
If Not isHoliday Then
weekdays = weekdays + 1
End If
Else
' If we're not including holidays, just increment the weekdays count.
weekdays = weekdays + 1
End If
End If
' Move to the next date.
currentDate = currentDate + 1
Loop
' Return the count of weekdays.
CalculateWeekdays = weekdays
Exit_Err_Handler:
Exit Function
Err_Handler:
MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description & vbCrLf & "Procedure: CalculateWeekdays", vbCritical + vbOKOnly, "CalculateWeekdays - Error"
Resume Exit_Err_Handler
End Function
Public Function GetUSHolidays(ByVal targetYear As Integer) As Collection
On Error GoTo Err_Handler
' Initialize an XMLHTTP object to fetch data from Nager.Date
Dim xmlHttpRequest As Object
Set xmlHttpRequest = CreateObject("Microsoft.XMLHTTP")
' Construct the URL for fetching U.S. holidays for the specified year.
Dim apiUrl As String
apiUrl = "https://date.nager.at/api/v3/publicholidays/" & targetYear & "/US"
' Set up and execute the HTTP request.
With xmlHttpRequest
.Open "GET", apiUrl, False
.setRequestHeader "Content-Type", "text/xml"
.send
End With
' Parse the response JSON to extract the list of holidays.
Dim parsedJson As Object
Set parsedJson = JsonConverter.ParseJson(xmlHttpRequest.responseText)
' Initialize a collection to store the dates of the holidays.
Dim holidaysCollection As Collection
Set holidaysCollection = New Collection
' Loop through each holiday in the parsed JSON and add its date to the collection.
Dim holidayData As Variant
For Each holidayData In parsedJson
holidaysCollection.Add CDate(holidayData("date"))
Next holidayData
' Assign the populated collection to the function's return value.
Set GetUSHolidays = holidaysCollection
Exit_Err_Handler:
' Clean up
Set xmlHttpRequest = Nothing
Set holidaysCollection = Nothing
Exit Function
Err_Handler:
MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description & vbCrLf & "Procedure: GetUSHolidays", vbCritical + vbOKOnly, "GetUSHolidays - Error"
Resume Exit_Err_Handler
End Function
Private Function ExistsInCollection(ByVal col As Collection, ByVal value As Variant) As Boolean
On Error Resume Next
Dim temp As Variant
temp = col(value)
ExistsInCollection = (Err.Number = 0)
Err.Clear
End Function
