Hi All can you please help me with a VBA code for Last Working Day, which excludes the weekends only, of the Previous Month?
The one I tried below is giving me only the Last date without the working day.
Range("B8") = Application.WorksheetFunction.EoMonth(Now, -1)
How about:
Sub marine()
Dim dt As Date, dt_LastMonth As Date, dt_LastWorkingDate_LastMonth As Date
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
dt = Now
dt_LastMonth = DateSerial(Year(dt), Month(dt) - 1, 1)
dt_LastWorkingDate_LastMonth = wf.WorkDay(wf.EoMonth(dt_LastMonth, 0) + 1, -1)
MsgBox dt_LastWorkingDate_LastMonth
End Sub
If today is a day in May 2021, the code produces:
Here is a simple function to return the last workday of the previous month.
Private Function LastWorkday() As Date
Dim Fun As Date ' function return value
Fun = DateSerial(Year(Date), Month(Date), 0)
Do
If (Weekday(Fun) < vbSaturday) And _
(Weekday(Fun) > vbSunday) Then Exit Do
Fun = Fun - 1
Loop
LastWorkday = Fun
Debug.Print Format(Fun, "ddd, d mmm yyyy")
End Function
Related
I need to automatically calculate a Start Date (aka QRT_START) which is 5 years of Quarters back. A Quarter is 3 months. For example, there are 4 Quarters in a Year: March 31st, June 30th, September 30th and December 31st.
Since we are currently in November 16th 2022, the Start Date would be December 31st 2017. So depending on whatever the current date is, the Start Date needs to go back 5 years worth of Quarters.
I also need to automatically calculate the most recent End Date (aka QRT_END). So since, we are in November 16th 2022, the End Date would be the previous quarter end before today which is September 30th 2022. I have the VBA code written below, please help me fix.
Private Function getQRT_END() As String
Dim endmonth As Variant
Dim endyear As Variant
Dim Day As Variant
endmonth = Month(Date) - 1
If endmonth = 0 Then
endyear = Year(Date) - 1
endmonth = 12
day = 31
Else
endyear = Year(Date)
If endmonth = 3 Then
day = 31
Else
day = 30
End if
endmonth = “0” & endmonth
End If
getQRT_END = endyear & endmonth & day
End Function
Private Function getQRT_START() As String
Dim startmonth As Variant
Dim startyear As Variant
Dim Day As Variant
startyear = Year(Date) - 5
startmonth = Month(Date) + 2
If startmonth <10 Then
If startmonth = 3 Then
day = 31
Else
day = 30
End if
startmonth = “0” & startmonth
Else
day = 30
End If
getQRT_START = startyear & startmonth & day
End Function
Function GetQuartal(years, data)
d = DateAdd("yyyy", years, data)
q = (Month(d) + 2) \ 3
qstart = DateSerial(Year(d), (q - 1) * 3 + 1, 1)
qend = DateSerial(Year(d), q * 3 + 1, 1) - 1
GetQuartal = Array(data, d, qstart, qend)
End Function
Sub test()
Debug.Print "Date", "Date-5Y", "QY-5 Start", "QY-5 End"
For Each d In Array(Date, #2/29/2000#, #12/1/2021#, #5/5/1992#)
q = GetQuartal(-5, d)
Debug.Print q(0), q(1), q(2), q(3)
Next
End Sub
Date Date-5Y QY-5 Start QY-5 End
17.11.2022 17.11.2017 01.10.2017 31.12.2017
29.02.2000 28.02.1995 01.01.1995 31.03.1995
01.12.2021 01.12.2016 01.10.2016 31.12.2016
05.05.1992 05.05.1987 01.04.1987 30.06.1987
You can use two functions found in my library at GitHub: VBA.Date.
? DateThisQuarterUltimo(DateAdd("yyyy", -5, Date))
2017-12-31
? DatePreviousQuarterUltimo(DateAdd("yyyy", -5, Date))
2017-09-30
They are simple high-level functions:
' Returns the ultimo date of the quarter of the date passed.
'
' 2016-01-13. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function DateThisQuarterUltimo( _
ByVal DateThisQuarter As Date) _
As Date
Dim Interval As String
Dim Number As Double
Dim ResultDate As Date
Number = 0
Interval = IntervalSetting(DtInterval.dtQuarter)
ResultDate = DateIntervalUltimo(Interval, Number, DateThisQuarter)
DateThisQuarterUltimo = ResultDate
End Function
' Returns the ultimo date of the quarter preceding the quarter of the date passed.
'
' 2016-01-13. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function DatePreviousQuarterUltimo( _
ByVal DateThisQuarter As Date) _
As Date
Dim Interval As String
Dim Number As Double
Dim ResultDate As Date
Number = -1
Interval = IntervalSetting(DtInterval.dtQuarter)
ResultDate = DateIntervalUltimo(Interval, Number, DateThisQuarter)
DatePreviousQuarterUltimo = ResultDate
End Function
Haven't tested it completely
You can use DateSerial, DateAdd and DatePart to achieve what you want...
Option Explicit
Sub Sample()
Dim D As Date
Dim prevD As Date
D = DateSerial(2022, 11, 16)
'~~> Date 5 years years ago
prevD = DateAdd("q", -(4 * 5), D)
'~~> Last date of the quarter for a specific date
Debug.Print DateAdd("q", DatePart("q", prevD), DateSerial(Year(prevD), 1, 1)) - 1
'OUTPUT : 31-12-2017
'~~> Last date of previous quarter for a specific date
Debug.Print DateAdd("q", DatePart("q", D) - 1, DateSerial(Year(D), 1, 1)) - 1
'OUTPUT : 30-09-2022
End Sub
Changed string part to a proper date.
I'm still getting the hang of more complex formulas in VBA.
I'm wanting to create a system that can calculate the worked hours for a certain projects. For example, say my shift hours are 6AM-330PM. I start a project at 7AM on 11/14 and end it at 9AM on 11/16.
How would I go about making calculations so that the returned value will be the hours I worked while on the clock, and not a rolling 24-hour calculation? (While also skipping weekends if possible?)
Thanks!! Heres the code that Im trying to use....
Public Function NetWorkHours(dteStart As Date, dteEnd As Date) As Integer
Dim StDate As Date
Dim StDateD As Date
Dim StDateT As Date
Dim EnDate As Date
Dim EnDateD As Date
Dim EnDateT As Date
Dim WorkDay1Start As Date
Dim WorkDay1end As Date
Dim WorkDay2Start As Date
Dim WorkDay2end As Date
Dim Result As Integer
Dim MinDay As Integer
StDate = CDate(dteStart)
EnDate = CDate(dteEnd)
WorkDay1Start = DateValue(StDate) + TimeValue("08:00:00")
WorkDay1end = DateValue(StDate) + TimeValue("17:00:00")
WorkDay2Start = DateValue(EnDate) + TimeValue("08:00:00")
WorkDay2end = DateValue(EnDate) + TimeValue("17:00:00")
If (StDate > WorkDay1end) Then
StDate = DateAdd("d", 1, WorkDay1Start)
End If
If (StDate < WorkDay1Start) Then
StDate = WorkDay1Start
End If
If (EnDate > WorkDay2end) Then
EnDate = DateAdd("d", 1, WorkDay2Start)
End If
If (EnDate < WorkDay2Start) Then
EnDate = WorkDay2Start
End If
StDateD = CDate(Format(StDate, "Short Date"))
EnDateD = CDate(Format(EnDate, "Short Date"))
If StDateD = EnDateD Then
Result = DateDiff("n", StDate, EnDate, vbUseSystemDayOfWeek)
Else
MinDay = (8 * 60) 'Number of minutes of a working day. Change this if you change the start and end times.
'Extract the time from the two timestamps
StDateT = Format(StDate, "Short Time")
EnDateT = Format(EnDate, "Short Time")
'
'Calculate the minutes of the first day and the second one. Don't know what to do yet if the start is after 5pm or the end is before 8am
Result = DateDiff("n", StDateT, TimeValue("17:00:00"), vbUseSystemDayOfWeek)
Result = Result + DateDiff("n", TimeValue("08:00:00"), EnDateT, vbUseSystemDayOfWeek)
'Check if there was a break on both days or not.
If DateDiff("n", StDateT, TimeValue("17:00:00"), vbUseSystemDayOfWeek) > (5 * 60) Then
Result = Result - 60
End If
If DateDiff("n", TimeValue("08:00:00"), EnDateT, vbUseSystemDayOfWeek) > (5 * 60) Then
Result = Result - 60
End If
'Add 1 day to start date. This is to start the loop to get all the days between both dates.
StDateD = DateAdd("d", 1, StDateD)
Do Until StDateD = EnDateD
'If the date is not a saterday or a sunday we add one day.
If (Weekday(StDateD) > 1) And (Weekday(StDateD) < 7) Then
Result = Result + MinDay
'Check for the holiday. If the date is a holiday, then we remove one day
If Not IsNull(DLookup("[HolDate]", "Holidays", "[HolDate] = #" & Int(StDateD) & "#")) Then
Result = Result - MinDay
End If
End If
StDateD = DateAdd("d", 1, StDateD)
Loop
End If
NetWorkHours = Result
End Function
You can use DateDiff to calculate the difference between dates (and times). The following should get you pretty close to what you want to do:
Dim datStart As Date
Dim datEnd As Date
Dim sngShiftStart As Single
Dim sngShiftEnd As Single
Dim sngShiftDuration As Single
Dim lngMinutesWorked As Long
Dim lngOfftime As Long
Dim sngHoursWorked As Single
' Calculate shift length
sngShiftStart = 6
sngShiftEnd = 15.5
sngShiftDuration = sngShiftEnd - sngShiftStart
' Set start and end times
datStart = CDate("11/07/19 7:00")
datEnd = CDate("11/09/19 8:30")
lngMinutesWorked = DateDiff("n", datStart, datEnd)
lngOfftime = ((24 - sngShiftDuration) * 60) * (DateDiff("d", datStart, datEnd))
sngHoursWorked = (lngMinutesWorked - lngOfftime) / 60
MsgBox sngHoursWorked
This does not take into account weekends but you should be able to easily add that. You can check, using the Weekday function, if the Weekday of the Start date is smaller than the End date. In that case, subtract 2 * sngShiftDuration from sngHoursWorked. If your project lasts more than a week, you can look for that and subtract more weekends:
' Remove weekends
Dim sngWeekendHours As Single
If Weekday(datStart) > Weekday(datEnd) Then
' Weekend included
sngWeekendHours = (2 * sngShiftDuration) * (DateDiff("w", datStart, datEnd) + 1)
End If
sngHoursWorked = ((lngMinutesWorked - lngOfftime) / 60) - sngWeekendHours
How do I find if it's the first or second day of the month?
I'm just trying to see if it's the 1st, 2nd or less than the 5th day of the month to do something.
If Date = Application.WorkDay(DateSerial(Year(Date), Month(Date), 0), 1) Or _
Date = Application.WorkDay(DateSerial(Year(Date), Month(Date), 0), 2) Or _
Date = Application.WorkDay(DateSerial(Year(Date), Month(Date), 0), 3) Then
MsgBox "1st, 2nd or 3rd day of month"
End If
End Sub
Thanking you all in advance
Here's a function to test if a date (or if unspecified, today) is within the first X working days:
Function date_is_in_X_days(firstXdays As Integer, Optional dt As Date) As Boolean
If dt = 0 Then dt = Date
date_is_in_X_days = False
With WorksheetFunction
For t = 1 To firstXdays
If dt = .WorkDay(.EoMonth(dt, -1), t) Then
date_is_in_X_days = True
Exit For
End If
Next
End With
End Function
To test this:
Sub test_function()
If date_is_in_X_days(3) Then MsgBox "1st, 2nd or 3rd day of month"
End Sub
Another way using DAY as #Warcupine suggested.
Public Function date_is_in_X_days(DayNumber As Long, Optional DateValue As Date) As Boolean
If DateValue = 0 Then DateValue = Date
date_is_in_X_days = Day(DateValue) < DayNumber 'Compare the two values which returns TRUE or FALSE
End Function
This can then be used as:
Public Sub Test()
Debug.Print date_is_in_X_days(4) 'False if today is >= 4th.
Debug.Print date_is_in_X_days(2, DateValue("3-Sep-19")) 'False as 3rd is later than 2nd.
Debug.Print date_is_in_X_days(4, DateValue("3-Sep-19")) 'True as 3rd is earlier than 4th.
End Sub
or as a worksheet formula where A1 contains a date:
=date_is_in_X_days(5,$A$1)
So I have a macro that I only want to run on weekdays. I created the macro that (I'm hoping) will check what day of the week it is and put that into a cell. This is what I have:
Private Sub dayCheck()
If Weekday(Now) = vbMonday Or vbTuesday Or vbWednesday Or vbThursday Or vbFriday Then
Dim BlankRow As Long
BlankRow = Range("A65536").End(xlUp).Row + 1
Cells(BlankRow, 1).Select
Selection.Value = Date
Selection.Offset(0, 1).Value = Time
Selection.Offset(0, 2).Value = WeekdayName(Weekday(Now))
Selection.Offset(0, 3).Value = Environ("Username")
ElseIf Weekday(Now) = vbSaturday Or vbSunday Then
Dim time1, time2
Do
time1 = Weekday(Now)
time2 = vbMonday
Do Until time1 = time2
DoEvents
time1 = Now()
Loop
Loop
End If
Application.OnTime TimeValue("12:00:00"), "dayCheck"
End Sub
My problem is I don't have administrator rights to change the system date. Is there a way I can simulate this through a macro?
You can simulate the date code by formatting the general or number output of the now() function in excel and just add 1 to increment the date. Numbers to the right of the decimal represent the percent of time beyond midnight until the next day.
Today's datetime code is: 43412.37786
Tomorrow is 43413.37786
So your question about testing your code can be answered by creating a for loop with:
Dim Today
Today = Now
For Days = Today To Today + 7 'Tests today through next Thursday.
If Weekday(Days) = ...
Next Days
But Darren's answer looks like it solves your problem, so I'd probably just go with that.
Now gives the date/time, Date gives just the date.
Weekday(Date) returns the current day number of the week with Sunday being 1.
As it's Thursday today Weekday(Now)=vbMonday will return False.
Weekday(Now) = vbMonday Or vbTuesday Or vbWednesday Or vbThursday Or vbFriday returns 7 - I'm not sure why, but it does. The main thing here is it doesn't return TRUE or FALSE.
For that statement to work you'd have to use
Weekday(Now) = vbMonday Or Weekday(Now) = vbTuesday Or Weekday(Now) = vbWednesday Or Weekday(Now) = vbThursday Or Weekday(Now) = vbFriday.
An easier way is Weekday(Date,vbMonday)<=5 - vbMonday numbers the week Monday = 1, Sunday = 7 and it answers the question "Is date a weekday?".
Here's the code:
Sub Test()
'DayCheck Now
'Or
'DayCheck #11/7/2018 6:55:00 PM#
'Or look at next 7 days starting now.
Dim x As Long
Dim StartDate As Date
StartDate = Now
For x = 0 To 6
DayCheck StartDate + x
Next x
End Sub
Sub DayCheck(MyDate As Date)
Dim rLastCell As Range
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets("Sheet1")
If Weekday(MyDate, vbMonday) <= 5 Then
Set rLastCell = wrkSht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'Reference to the blank cell itself.
rLastCell.Resize(, 4) = Array(MyDate, MyDate, MyDate, Environ("Username"))
rLastCell.NumberFormat = "dd-mmm-yy"
rLastCell.Offset(, 1).NumberFormat = "hh:mm AM/PM"
rLastCell.Offset(, 2).NumberFormat = "dddd"
Else 'No need to check if it's a weekend - we know it's not a weekday.
'Just keep running until time1 = 2 and time2 = 2?
'I guess that'll be Midnight on Monday?
End If
End Sub
Note I'm putting the same value in columns A:C - just the date and time.
I then format each cell to show the part of the date & time you're interested in.
When planning projects we give a approximate duration in weeks. A project starts on the next Monday from today.
Public Function NextMonday() As Date
Dim D As Integer
Dim N As Date
D = Weekday(Now)
N = Now() + (9 - D)
NextMonday = N
End Function
With this code I can assign the right date to a cell (Next Monday). Now i need to get the next Friday 12 weeks from that date. (84 Days)
For this i used the previous code and adjusted it a little.
Public Function NextFriday(AproxDate As Date) As Date
Dim E As Integer
Dim M As Date
E = Weekday(Now)
M = AproxDate + (14 - E)
NextFriday = M
End Function
Now for the main module the code looks like;
Private Sub Worksheet_Activate()
Dim wbCurrent As Workbook
Dim wsCurrent As Worksheet
Dim StartDate As Range
Dim AproxDate As Date
Dim EndDate As Range
Set wbCurrent = ThisWorkbook
Set wsCurrent = wbCurrent.Sheets("Sheet1")
Set StartDate = wsCurrent.Range("C15")
Set EndDate = wsCurrent.Range("C16")
Call NextMonday
StartDate.Value = NextMonday
'Setting Monday 12 weeks from StartDate
AproxDate = NextMonday + 84
Call NextFriday(AproxDate)
EndDate.Value = NextFriday
End Sub
The NextMonday part works fine, but when running the NextFriday i get an "Argument Not Optional" When trying to set the EndDate.Value = NextFriday.
I cant seem to find the problem with this code. Any thoughts?
This is not how you get a value from a function:
Call NextFriday(AproxDate)
EndDate.Value = NextFriday
If you want the value that function NextFriday returns based on (AproxDate) and you want that value in cell EndDate then (instead of both lines above) you would use:
EndDate.Value = NextFriday(AproxDate)
You only use Call with a function if you do not want a value to be returned from it.
Simplified Procedures:
Your procedure are needlessly overcomplicated.
Believe it or not, this is exactly the same as your procedures:
Public Function NextMonday() As Date
NextMonday = Now() + (9 - Weekday(Now))
End Function
Public Function NextFriday(AproxDate As Date) As Date
NextFriday = AproxDate + (14 - Weekday(Now))
End Function
Private Sub Worksheet_Activate()
.Range("C15")= NextMonday
ThisWorkbook.Sheets("Sheet1").Range("C16")= NextFriday(NextMonday + 84)
End Sub
Simplified even further:
Going a step further, this is 1 sub is exactly the same as the 3 procedures above:
Private Sub Worksheet_Activate()
With Sheets("Sheet1")
.Range("C15") = Now() + (9 - Weekday(Now))
.Range("C16") = (.Range("C15") + 84) + (14 - Weekday(Now))
End With
End Sub
One more thing to note, function Now returns the current date+time. Id it's only the date you're interested in, use function Date.
You have 2 mistakes in your Next Friday function.
1) from Monday to Friday in Weekdays is +4 and not +5 (so you get Next Monday = +9 and next Friday = +(9+4) )
2) You took the now() instead of aproxdate in the next friday code
Your code for next friday should be:
Public Function NextFriday(AproxDate As Date) As Date
Dim E As Integer
Dim M As Date
E = Weekday(AproxDate)
M = AproxDate + (13 - E)
NextFriday = M
End Function
Then you can call the function as in the other answer
var d = new Date();
d.setDate(d.getDate() + (5+7 - d.getDay()) % 7);
document.write(d);
This is a Javascript code which will result you next friday, the only condition where it fails if it is a friday.