Get dates between 2 sets of dates excluding non workdays - vba

I am using a function to get dates between 2 sets of dates, it works, however I would like to only get dates that are workdays:
Have tried incorporating
Application.WorksheetFunction.WorkDay but I am still getting non workdays in the set of dates - any suggestions?
Original function:
Public Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(0 To CLng(EndDate) - CLng(StartDate))
For lngDateCounter = LBound(varDates) To UBound(varDates)
varDates(lngDateCounter) = CDate(StartDate)
StartDate = CDate(CDbl(StartDate) + 1)
Next lngDateCounter
getDates = varDates
End Function
Trial to exclude non workdays:
Public Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(0 To CLng(EndDate) - CLng(StartDate))
For lngDateCounter = LBound(varDates) To UBound(varDates)
varDates(lngDateCounter) = CDate(Application.WorksheetFunction.WorkDay(StartDate, 0))
StartDate = CDate(CDbl(StartDate) + 1)
Next lngDateCounter
getDates = varDates
End Function

Give this a try:
The collections for holidays (fixed and floating) are initialized with hard coded dates but it would be better if the dates were read from a worksheet or table.
Private mFixedHolidays As Collection
Private mFloatingHolidays As Collection
Public Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(0 To CLng(EndDate) - CLng(StartDate))
Dim dTotalWorkdays As Long
dTotalWorkdays = 0
Dim dDate As Date
dDate = StartDate
For lngDateCounter = LBound(varDates) To UBound(varDates)
If Not (IsWeekendDay(dDate) Or IsFixedHoliday(dDate) Or IsFloatingHoliday(dDate)) Then
varDates(dTotalWorkdays) = dDate
dTotalWorkdays = dTotalWorkdays + 1
End If
dDate = CDate(CDbl(dDate) + 1)
Next lngDateCounter
ReDim Preserve varDates(dTotalWorkdays - 1)
getDates = varDates
End Function
Private Function IsWeekendDay(ByVal dateOfInterest As Date) As Boolean
IsWeekendDay = _
Weekday(dateOfInterest) = VbDayOfWeek.vbSaturday _
Or Weekday(dateOfInterest) = VbDayOfWeek.vbSunday
End Function
Private Function IsFixedHoliday(ByVal dateOfInterest As Date) As Boolean
Dim result As Boolean
result = False
If mFixedHolidays Is Nothing Then
Set mFixedHolidays = New Collection
'Year portion of dates will be ignored
With mFixedHolidays
.Add "7/4/2022"
.Add "12/25/2022"
.Add "1/1/2022"
'Add other fixed date holidays
End With
End If
Dim fixedDate As Date
Dim dateToken As Variant
For Each dateToken In mFixedHolidays
fixedDate = DateValue(dateToken)
If Month(fixedDate) = Month(dateOfInterest) And Day(fixedDate) = Day(dateOfInterest) Then
result = True
Exit For
End If
Next
IsFixedHoliday = result
End Function
Private Function IsFloatingHoliday(ByVal dateOfInterest As Date) As Boolean
Dim result As Boolean
result = False
If mFloatingHolidays Is Nothing Then
Set mFloatingHolidays = New Collection
With mFloatingHolidays
.Add "5/30/2022" 'Memorial Day
'Add other floating date holidays
End With
End If
Dim floatingDate As Date
Dim dateToken As Variant
For Each dateToken In mFloatingHolidays
floatingDate = DateValue(dateToken)
If floatingDate = dateOfInterest Then
result = True
Exit For
End If
Next
IsFloatingHoliday = result
End Function

Related

Setting recurrence end date

I stepped through this multiple times and it executes without issue.
I set up a watch on "Item.GetReccurrencePattern.PatternEndDate" for the calling procedure (i.e. Application_Reminder event) and the end date does change.
But, when I view my calendar, the additional meetings haven't been created.
And when I open up an occurrence of the meeting, it shows the original end date in the recurrence settings.
Private Sub Application_Reminder(ByVal Item As Object)
If Item.MessageClass <> "IPM.Appointment" Then Exit Sub
Dim myItem As AppointmentItem
Set myItem = Item
Dim DoIt As Boolean
Select Case myItem.ConversationTopic
Case "TEST"
DoIt = True
'Will use this for multiple meetings, that's why using select
End Select
If DoIt Then ExtendAppt myItem
Set myItem = Nothing
End Sub
Private Sub ExtendAppt(ByRef myApptItem As Outlook.AppointmentItem)
Dim myRecurrPatt As Outlook.RecurrencePattern
Set myRecurrPatt = myApptItem.GetRecurrencePattern
Dim origStart As Date
Dim origEnd As Date
Dim thisWeek As Date
Dim recDate As Long
Dim deltaEnd As Long
Dim newEnd As Date
Dim howMany As Long
origStart = myRecurrPatt.PatternStartDate
origEnd = myRecurrPatt.PatternEndDate
Select Case myRecurrPatt.DayOfWeekMask
Case olFriday
recDate = vbFriday
Case olMonday
recDate = vbMonday
Case olTuesday
recDate = vbTuesday
Case olWednesday
recDate = vbWednesday
Case olThursday
recDate = vbThursday
Case olFriday
recDate = vbFriday
Case olSaturday
recDate = vbSaturday
Case olSunday
recDate = vbSunday
Case Else
'not recurring or error
Exit Sub
End Select
thisWeek = Date - Weekday(Date, recDate) + 1
deltaEnd = DateDiff("ww", origEnd, thisWeek)
If deltaEnd Mod (2) = 0 Then howMany = 10 Else howMany = 9
newEnd = DateAdd("ww", howMany, thisWeek)
myRecurrPatt.PatternEndDate = newEnd
myApptItem.Save
'Release references to the appointment series
Set myApptItem = Nothing
Set myRecurrPatt = Nothing
End Sub

Get same nth day of the month in x number of months

I am needing some help converting a function from access vba to vb.net.
The script generates a new date, based on the date entered, and the number of months to be added.
“If today is the second Tuesday in March, what will be the second Tuesday in 4 months?”
Public Function NdNwk(dType As String, _
dtSpan As Integer, sDate As Date) As Variant
' This Function RETURNS the DAY of WHICH WEEK
' (e.g. Second Tuesday of the Month).
' FUNCTIONS to be passed to Variables:
' gtDoW: Day of the WEEK of the START DATE.
' (1 for Sunday, 2 for Monday, etc.)
' gtWoM: WEEK of the MONTH of the START DATE.
' (1 for First, 2 for Second, etc.)
' gtDSTdt: Desired DATE
' (generated by the [DateAdd] Function).
' CALL EXAMPLE: If TODAY is Tuesday, March 10, 2020,
‘ (second Tuesday of March), then using
' NdNwk(m, 2, #5/21/2020#)
' Would generate the DATE 5/12/2020,
' As the SECOND TUESDAY of MAY.
Dim gtDSTdt As Date, gtWoM As Integer, gtDoW As Integer
Dim iLoop As Integer, iPick As Integer, dstDTdom As Date
gtDoW = Weekday(sDate)
gtWoM = (Int((Day(sDate) - 1) / 7) + 1)
gtDSTdt = DateAdd(dType, dtSpan, sDate)
For iLoop = 1 To Day(DateSerial(Year(gtDSTdt), _
Month(gtDSTdt) + 1, 0))
dstDTdom = DateSerial(Year(gtDSTdt), _
Month(gtDSTdt), iLoop)
If Weekday(dstDTdom, 1) = gtDoW Then
iPick = iPick + 1
If iPick = gtWoM Then
NdNwk = dstDTdom
Exit Function
End If
End If
Next
End Function
Any and all help is appreciated here.
I used several of the properties and methods of the .net DateTime structure. https://learn.microsoft.com/en-us/dotnet/api/system.datetime?view=netcore-3.1
The arithmetic in the Function used the Mod operator which returns the remainder of the division. The integer division (the formard slash \) returns the integer portion of the division.
The only other thing that might be unfamiliar is the interpolated string, a string starting with $"". This allows you to directly embed variables in the string surround by { }.
Private Function NdNwk(InputDate As Date, MonthsAhead As Integer) As String
Dim newDate As Date
Dim DofWeek = InputDate.DayOfWeek
Dim Day = InputDate.Day
Dim OfInputMonth As Integer
If Day Mod 7 = 0 Then
OfInputMonth = Day \ 7
Else
OfInputMonth = (Day \ 7) + 1
End If
Dim TempDate = InputDate.AddMonths(MonthsAhead)
Dim NewMonth = TempDate.Month
Dim NewYear = TempDate.Year
Dim FirstWeek As Date
Dim NewDay As Integer
For d = 1 To 7
FirstWeek = New Date(TempDate.Year, TempDate.Month, d)
If FirstWeek.DayOfWeek = DofWeek Then
NewDay = d
Exit For
End If
Next
Dim DaysToAdd = (OfInputMonth - 1) * 7
newDate = New Date(NewYear, NewMonth, NewDay).AddDays(DaysToAdd)
Dim NewDateString = $"{newDate.ToString("MM/dd/yyyy")} is the {GetOrdinalString(OfInputMonth)} {DofWeek} of {TempDate.ToString("MMMM")}, {TempDate.Year}"
Return NewDateString
End Function
Private Function GetOrdinalString(input As Integer) As String
Dim output As String
Select Case input
Case 1
output = "1St"
Case 2
output = "2nd"
Case 3
output = "3rd"
Case 4
output = "4th"
Case 5
output = "5th"
Case Else
output = ""
End Select
Return output
End Function
Usage...
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim InputDate As Date
Dim MonthsToAdd As Integer
If Not Date.TryParse(TextBox1.Text, InputDate) Then
MessageBox.Show("Please enter a valid date in Date")
Return
End If
If Not Integer.TryParse(TextBox2.Text, MonthsToAdd) Then
MessageBox.Show("Please enter a valid number in Months To Add")
Return
End If
Dim d = NdNwk(InputDate, MonthsToAdd)
MessageBox.Show(d)
End Sub
First of all, thanks for all the feedback.
The solution that I was able to parse together is as follows:
A text box to show the number of months.
A text box to show the new date.
A button click action to run the following code:
Private Sub BtnMonth_Click(sender As Object, e As EventArgs) Handles BtnMonth.Click
Dim WrkDt As Date = Now
Dim QtyMnths As Integer = CType(TxtMntCount.Text, Int32)
Dim newFoM = New Date(WrkDt.Year, WrkDt.Month, 1).AddMonths(QtyMnths)
Dim DoWDt As Integer = WrkDt.DayOfWeek
Dim newMntdate = newFoM.AddDays(Enumerable.Range(0,
Date.DaysInMonth(newFoM.Year, newFoM.Month) - 1).Where(Function(i) newFoM.AddDays(i).DayOfWeek = DoWDt).Skip(1).First())
TxtNewDate.Text = Format(newMntdate, "MMMM dd, yyyy (ddd)")
End Sub
This works perfectly fine for me!
Mary's solution looks great, and I will give it a shot in the future when I need a modular input.
Thanks again for all the help!
I tested your solution, and it doesn’t produce the described results.
See test and correct solution at: https://dotnetfiddle.net/v5wGng
A couple of things from your original problem, you should prefer calculation to loops wherever possible, and you should use the required types wherever possible. If you have date in one format (string) and need it in another for your calculations, you should do the conversion and then call a function that does your calculations where all of the parameters are of the correct type.
Public Function GetSameWeekAndWeekDay(dt as date, months as integer) as Date
Dim newMonth =(new date(dt.year, dt.month, 1)).AddMonths(Months)
Dim week = getweek(dt)
Dim sameWeekDay = GetNthDayOfWeek(newMonth, week, dt.DayOfWeek)
Return SameWeekday
End Function
Public Function GetWeek(dt as date) as integer
Return(dt.day - 1) \ 7
End Function
Public Function GetNthDayOfWeek(dt as date, week as integer, weekDay as System.DayofWeek) as Date
Dim first = new Date(dt.year, dt.month, 1)
Dim baseDate = first.AddDays(-(first.DayOfWeek - system.dayofweek.Sunday))
Dim newDate = baseDate.AddDays((week * 7) + weekday)
If(newdate.DayOfWeek < first.DayOfWeek) then
newDate = newDate.AddDays(7)
End If
Return newdate
End Function

VBA function cannot return value to main sub

I have a problem:
Now I got a date range for a main sub (20160706-20160805) and I have to separate the value and put it as a date. What I do is:
Main sub date ()
Dim strDaterage as string
Dim startdate as date
'For the sake of simplicity, just use the hard code for the date
strDaterange = "20160706-20160805"
startdate = findstartdate()
msgbox (startdate)
End sub
And for the function to separate the date an extract the value:
Function findstartdate()
daterange = "20160706-20160805"
startDateange = Left(daterange, 8)
startYear = Left(startDateange, 4)
startMonth = Mid(startDateange, 5, 2)
startDay = Right(startDateange, 2)
startdate = DateSerial(startYear, startMonth, startDay)
End Function
I try using the byval and byfer but it still does not work. How can I return the date value back into the main sub?
Many thanks in advance!
Not sure why you are using a String as an input, but if you want you can use the code below (there are more efficient ways to do it).
Your Sub :
Sub SubDate()
Dim strDaterage As String
Dim startdate As Date
strDaterage = "20160706-20160805"
startdate = findstartdate(strDaterage)
MsgBox (startdate)
End Sub
Your function:
' need to add a String variable as an input, and return tha value as a Date
Function findstartdate(DateRange As String) As Date
startDateange = Left(DateRange, 8)
startYear = Left(startDateange, 4)
startMonth = Mid(startDateange, 5, 2)
startDay = Right(startDateange, 2)
startdate = DateSerial(startYear, startMonth, startDay)
' convert the string result to a Date
findstartdate = CDate(startdate)
End Function

vba type mismatch on my script

So, I'm getting a type mismatch in the VBA script of a Word document, however there isn't any line signaled on the editor... Can any of you give me an hint of what it might be?
Private Sub bt_run_Click()
'set months array
Dim months As Variable
months = Array("Janeiro", "Fevereiro", "Março", "Abril", "Maio", "Junho", "Julho", "Agosto", "Setembro", "Outubro", "Novembro", "Dezembro")
With ThisDocument.Tables(0)
Do While .Rows.Count > 2
.Rows(2).Delete
Loop
'Ask for year
Dim req As String
Dim yr As Integer
req = InputBox("Insere ano.")
If IsNumeric(req) Then
yr = CInt(req)
Else
MsgBox ("Erro")
Return
End If
'get previous year last week
'TODO
'Now generate current year months
For i = 1 To 12
'get number of mondays on the month (how many weeks belong here)
Dim mondays As Integer
mondays = MondaysOnMonth(i, yr)
'now generate a line for each monday
For k = 1 To mondays
.Rows.Add
Next k
Next i
'get next year first week
'TODO
End With
End Sub
Function MondaysOnMonth(ByVal month As Integer, ByVal year As Integer) As Integer
Dim mondays As Integer
mondays = 0
Dim d As Date
Dim dtStr As String
dtStr = "1/" & month & "/" & year
d = DateValue(dtStr)
Dim days As Integer
days = dhDaysInMonth(d)
For i = 1 To days
dtStr = i & "/" & month & "/" & year
d = DateValue(dtStr)
Dim w As Integer
w = Weekday(d, vbMonday)
If w = 0 Then
mondays = mondays + 1
End If
Next i
MondaysOnMonth = mondays
End Function
Function dhDaysInMonth(Optional ByVal dtmDate As Date = 0) As Integer
' Return the number of days in the specified month.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhDaysInMonth = DateSerial(year(dtmDate), _
month(dtmDate) + 1, 1) - _
DateSerial(year(dtmDate), month(dtmDate), 1)
End Function
This pretty much generates how many lines as there're mondays in the entire year in the only table of the document.
I'm not really experienced in all this thing of Visual Basic for Applications, but I'm assuming it's some type casting that the compiler can't execute, however, I can't really see what it might be (and the compiler isn't giving me the necessary help), so what might it be?
In my (limited) experience, arrays are setup a little differently in VBA:
'set months array
Dim months(11) As String
months(0) = "Janeiro"
months(1) = "Fevereiro"
months(2) = "Março"
months(3) = "Abril"
months(4) = "Maio"
months(5) = "Junho"
months(6) = "Julho"
months(7) = "Agosto"
months(8) = "Setembro"
months(9) = "Outubro"
months(10) = "Novembro"
months(11) = "Dezembro"
Also, I could not address table 0, so changed it to table 1 and the code seemed to execute.
With ThisDocument.Tables(1)
Hope this helps!
Array Function
Returns a Variant containing an array!!!
Dim months As Variant
You were so close.
In your original code, you should be able to change Variable to Variant and the initialization will work as you expected.
Here I've copy/pasted your array initialization, swapped in Variant, and written a loop that confirms the array was properly initialized by printing the values to the Immediate Window (press Ctrl+G to view if it is not already visible):
Sub TestMonthArrayInitialization()
Dim months As Variant
months = Array("Janeiro", "Fevereiro", "Março", "Abril", "Maio", "Junho", "Julho", "Agosto", "Setembro", "Outubro", "Novembro", "Dezembro")
Dim i As Integer
For i = 0 To 11
Debug.Print months(i)
Next i
End Sub

Array of Workdays

I am looking for a way to store the last workday of each month between two "Input dates", and I need to store them as Strings in an array. I have tried to use the Worksheet function "Workday", but my input dates are of the format dd-mm-yyy, and I coundn't get it to work..
Any help is appreciated, Thanks.
Too bad, i've assumed that your VB.NET tag was the correct one, now it's removed. However, if someone needs something similar in .NET this might be helpful:
Dim fromDate = DateTime.Today.AddYears(-1) ' sample days
Dim toDate = DateTime.Today
Dim startDay = New Date(fromDate.Year, fromDate.Month, 1).AddMonths(1)
Dim endDay = New Date(toDate.Year, toDate.Month, 1).AddMonths(1)
Dim monthsBetween As Int32 = GetMonthsBetween(startDay, endDay)
Dim nonWorkingDays = {DayOfWeek.Saturday, DayOfWeek.Sunday}
Dim workingDatesBetween As New List(Of String)
For month As Int32 = 0 To monthsBetween
Dim d As DateTime = startDay.AddMonths(month)
' look into last months last days, shorter way
Dim lastWorkingDay As Date = Date.MinValue
While lastWorkingDay = Date.MinValue
d = d.AddDays(-1) ' look backwards into the last month to find the last working-day
If Not nonWorkingDays.Contains(d.DayOfWeek) Then
lastWorkingDay = d
workingDatesBetween.Add(lastWorkingDay.ToString("dd-MM-yyy", CultureInfo.InvariantCulture))
End If
End While
Next
Dim result = workingDatesBetween.ToArray()
This method was used to determine the number of months between two dates:
Public Shared Function GetMonthsBetween(date1 As DateTime, date2 As DateTime) As Int32
Dim months = Math.Abs(((date1.Year - date2.Year) * 12) + date1.Month - date2.Month)
Return months
End Function
or as reusable method (although i doubt that someone needs this method often):
Public Shared Function GetLastWorkingDatesInMonthBetween(fromDate As Date, toDate As Date) As Date()
Dim startDay = New Date(fromDate.Year, fromDate.Month, 1).AddMonths(1)
Dim endDay = New Date(toDate.Year, toDate.Month, 1).AddMonths(1)
Dim monthsBetween As Int32 = GetMonthsBetween(startDay, endDay)
Dim nonWorkingDays = {DayOfWeek.Saturday, DayOfWeek.Sunday}
Dim workingDatesBetween As New List(Of Date)
For month As Int32 = 0 To monthsBetween
Dim d As DateTime = startDay.AddMonths(month)
' look into last months last days, shorter way
Dim lastWorkingDay As Date = Date.MinValue
While lastWorkingDay = Date.MinValue
d = d.AddDays(-1) ' look backwards into the last month to find the last working-day
If Not nonWorkingDays.Contains(d.DayOfWeek) Then
lastWorkingDay = d
workingDatesBetween.Add(d)
End If
End While
Next
Return workingDatesBetween.ToArray()
End Function
Now you get the String() from the Date() via Array.ConvertAll:
Dim allNonWorkingDates = GetLastWorkingDatesInMonthBetween(DateTime.Today.AddYears(-1), DateTime.Today)
Dim result As String() = Array.ConvertAll(allNonWorkingDates, Function(d) d.ToString("dd-MM-yyy", CultureInfo.InvariantCulture))
Result with the sample year above:
30-09-2013
31-10-2013
29-11-2013
31-12-2013
31-01-2014
28-02-2014
31-03-2014
30-04-2014
30-05-2014
30-06-2014
31-07-2014
29-08-2014
30-09-2014