End Date of project
Hi Experts...
I have form named frmProject.. and I have 3 text box
1-txt for startDate
2-txt for project duration in days
3- txt EndDate
when I put startDate like 1/1/2019 ..and I have as example 30 days for project duration
what I want that in after update the txt for project duration in days I will obtain the end date of project in txt EndDate without friday and saturday
i mean it will appear in 11/2/2019..
thank you
I have form named frmProject.. and I have 3 text box
1-txt for startDate
2-txt for project duration in days
3- txt EndDate
when I put startDate like 1/1/2019 ..and I have as example 30 days for project duration
what I want that in after update the txt for project duration in days I will obtain the end date of project in txt EndDate without friday and saturday
i mean it will appear in 11/2/2019..
thank you
ASKER
Oh, sorry.
You can just comment that out if you won't count for holidays.
Or, here is the function:
You can just comment that out if you won't count for holidays.
Or, here is the function:
' Returns the holidays between Date1 and Date2.
' The holidays are returned as an array with the
' dates ordered ascending, optionally descending.
'
' The array is declared static to speed up
' repeated calls with identical date parameters.
'
' Requires table Holiday with list of holidays.
'
' 2015-12-18. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function GetHolidays( _
ByVal Date1 As Date, _
ByVal Date2 As Date, _
Optional ByVal OrderDesc As Boolean) _
As Date()
' Constants for the arrays.
Const DimRecordCount As Long = 2
Const DimFieldOne As Long = 0
Static Date1Last As Date
Static Date2Last As Date
Static OrderLast As Boolean
Static DayRows As Variant
Static Days As Long
Dim rs As DAO.Recordset
' Cannot be declared Static.
Dim Holidays() As Date
If DateDiff("d", Date1, Date1Last) <> 0 Or _
DateDiff("d", Date2, Date2Last) <> 0 Or _
OrderDesc <> OrderLast Then
' Retrieve new range of holidays.
Set rs = DatesHoliday(Date1, Date2, OrderDesc)
' Save the current set of date parameters.
Date1Last = Date1
Date2Last = Date2
OrderLast = OrderDesc
Days = rs.RecordCount
If Days > 0 Then
' As repeated calls may happen, do a movefirst.
rs.MoveFirst
DayRows = rs.GetRows(Days)
' rs is now positioned at the last record.
End If
rs.Close
End If
If Days = 0 Then
' Leave Holidays() as an unassigned array.
Erase Holidays
Else
' Fill array to return.
ReDim Holidays(Days - 1)
For Days = LBound(DayRows, DimRecordCount) To UBound(DayRows, DimRecordCount)
Holidays(Days) = DayRows(DimFieldOne, Days)
Next
End If
Set rs = Nothing
GetHolidays = Holidays()
End FunctionASKER
A function more was needed. Here is the full code of the module:
project.zip
Option Compare Database
Option Explicit
Public Const DaysPerWeek As Long = 7
' Workdays per week.
Public Const WorkDaysPerWeek As Long = 5
' Average count of holidays per week maximum.
Public Const HolidaysPerWeek As Long = 1
' Adds Number of full workdays to Date1 and returns the found date.
' Number can be positive, zero, or negative.
' Optionally, if WorkOnHolidays is True, holidays are counted as workdays.
'
' Will add 500 workdays in about 0.01 second.
'
' Requires table Holiday with list of holidays.
'
' 2015-12-19. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function DateAddWorkdays( _
ByVal Number As Long, _
ByVal Date1 As Date, _
Optional ByVal WorkOnHolidays As Boolean) _
As Date
Const Interval As String = "d"
Dim Holidays() As Date
Dim Days As Long
Dim DayDiff As Long
Dim MaxDayDiff As Long
Dim Sign As Long
Dim Date2 As Date
Dim NextDate As Date
Dim DateLimit As Date
Dim HolidayId As Long
Sign = Sgn(Number)
NextDate = Date1
If Sign <> 0 Then
If WorkOnHolidays = True Then
' Holidays are workdays.
Else
' Retrieve array with holidays between Date1 and Date1 + MaxDayDiff.
' Calculate the maximum calendar days per workweek.
MaxDayDiff = Number * DaysPerWeek / (WorkDaysPerWeek - HolidaysPerWeek)
' Add one week to cover cases where a week contains multiple holidays.
MaxDayDiff = MaxDayDiff + Sgn(MaxDayDiff) * DaysPerWeek
Date2 = DateAdd(Interval, MaxDayDiff, Date1)
' Retrive array with holidays.
Holidays = GetHolidays(Date1, Date2)
End If
Do Until Days = Number
DayDiff = DayDiff + Sign
NextDate = DateAdd(Interval, DayDiff, Date1)
Select Case Weekday(NextDate)
Case vbSaturday, vbSunday
' Skip weekend.
Case Else
' Check for holidays to skip.
' Ignore error when using LBound and UBound on an unassigned array.
On Error Resume Next
For HolidayId = LBound(Holidays) To UBound(Holidays)
If Err.Number > 0 Then
' No holidays between Date1 and Date2.
ElseIf DateDiff(Interval, NextDate, Holidays(HolidayId)) = 0 Then
' This NextDate hits a holiday.
' Subtract one day before adding one after the loop.
Days = Days - Sign
Exit For
End If
Next
On Error GoTo 0
Days = Days + Sign
End Select
Loop
End If
DateAddWorkdays = NextDate
End Function
' Returns the holidays between Date1 and Date2.
' The holidays are returned as an array with the
' dates ordered ascending, optionally descending.
'
' The array is declared static to speed up
' repeated calls with identical date parameters.
'
' Requires table Holiday with list of holidays.
'
' 2015-12-18. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function GetHolidays( _
ByVal Date1 As Date, _
ByVal Date2 As Date, _
Optional ByVal OrderDesc As Boolean) _
As Date()
' Constants for the arrays.
Const DimRecordCount As Long = 2
Const DimFieldOne As Long = 0
Static Date1Last As Date
Static Date2Last As Date
Static OrderLast As Boolean
Static DayRows As Variant
Static Days As Long
Dim rs As DAO.Recordset
' Cannot be declared Static.
Dim Holidays() As Date
If DateDiff("d", Date1, Date1Last) <> 0 Or _
DateDiff("d", Date2, Date2Last) <> 0 Or _
OrderDesc <> OrderLast Then
' Retrieve new range of holidays.
Set rs = DatesHoliday(Date1, Date2, OrderDesc)
' Save the current set of date parameters.
Date1Last = Date1
Date2Last = Date2
OrderLast = OrderDesc
Days = rs.RecordCount
If Days > 0 Then
' As repeated calls may happen, do a movefirst.
rs.MoveFirst
DayRows = rs.GetRows(Days)
' rs is now positioned at the last record.
End If
rs.Close
End If
If Days = 0 Then
' Leave Holidays() as an unassigned array.
Erase Holidays
Else
' Fill array to return.
ReDim Holidays(Days - 1)
For Days = LBound(DayRows, DimRecordCount) To UBound(DayRows, DimRecordCount)
Holidays(Days) = DayRows(DimFieldOne, Days)
Next
End If
Set rs = Nothing
GetHolidays = Holidays()
End Function
' Returns the holidays between Date1 and Date2.
' The holidays are returned as a recordset with the
' dates ordered ascending, optionally descending.
'
' Requires table Holiday with list of holidays.
'
' 2015-12-18. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function DatesHoliday( _
ByVal Date1 As Date, _
ByVal Date2 As Date, _
Optional ByVal ReverseOrder As Boolean) _
As DAO.Recordset
' The table that holds the holidays.
Const Table As String = "Holiday"
' The field of the table that holds the dates of the holidays.
Const Field As String = "Date"
Dim rs As DAO.Recordset
Dim SQL As String
Dim SqlDate1 As String
Dim SqlDate2 As String
Dim Order As String
SqlDate1 = Format(Date1, "\#yyyy\/mm\/dd\#")
SqlDate2 = Format(Date2, "\#yyyy\/mm\/dd\#")
ReverseOrder = ReverseOrder Xor (DateDiff("d", Date1, Date2) < 0)
Order = IIf(ReverseOrder, "Desc", "Asc")
SQL = "Select " & Field & " From " & Table & " " & _
"Where " & Field & " Between " & SqlDate1 & " And " & SqlDate2 & " " & _
"Order By 1 " & Order
Set rs = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
Set DatesHoliday = rs
End Functionproject.zip
This question needs an answer!
Become an EE member today
7 DAY FREE TRIALMembers can start a 7-Day Free trial then enjoy unlimited access to the platform.
View membership options
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
Open in new window
Open in new window