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
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.
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
Problem
The following [mcve] will output an array of arrays of week numbers between two dates. It works when both dates are on the same year, however, some years have 52 weeks and start within the last days of the last year. And others have 53 weeks.
An example of 52 weeks is the 2020 calendar:
Where the first week begins on Dec 30.
And the example of 53 weeks is the 2016 calendar:
That begins only on Jan 4th.
Code
The following code is commented and outputs an array of arrays with the week numbers.
Sub w_test()
Dim Arr() As Variant, ArrDateW() As Variant
'Initial Date
DateI = DateSerial(2015, 5, 5)
'Final Date
DateF = DateSerial(2017, 9, 20)
'Difference in weeks between DateI and DateF
weekDif = DateDiff("ww", DateI, DateF) + k - 1
i = Weekday(DateI)
d = DateI
'If not Sunday, go back to last week, to start the loop
If i <> 1 Then
d = DateAdd("d", -(i - 1), d)
End If
ReDim ArrDateW(weekDif)
ReDim Arr(2)
'Loop on all weeks between two dates to populate array of arrays
For i = 0 To weekDif
'Date
Arr(0) = d
'Trying to solve problem with New Year
If Application.WorksheetFunction.WeekNum(d) = 53 Then
flag = True
End If
If flag = False Then
Arr(1) = Application.WorksheetFunction.WeekNum(d)
Else
Arr(1) = Application.WorksheetFunction.WeekNum(DateSerial(Year(d) + 1, 1, 1))
flag = False
End If
'Year
Arr(2) = Year(d)
'Populate array of arrays
ArrDateW(i) = Arr
'Next Week Number
d = DateAdd("ww", 1, d)
Next i
'To stop with Ctrl+F8
Debug.Print d
End Sub
Question
2015 had 53 weeks, however the program outputs the following:
And between 2016 and 2017, the output is a mess:
How to fix the program to output these week numbers correctly?
I went about it somewhat differently, relying on built-in VBA functions to correctly calculate the week numbers. Read about ISO week numbers is this answer and see how I'm using the DataPart function -- though you can substitute your own version of Ron de Bruin's ISO week number function if you feel it's warranted.
A couple of quick side notes:
Always use Option Explicit
Try to use more descriptive variable names. YOU know what you're talking about NOW. In a few months, you'll struggle to remember what d and Arr mean (even if it seems obvious now). It's just a good habit and makes the code self-documenting.
My example below breaks the logic into a separate function with an optional parameter (just for fun) that would allow the caller to change the start of the week to a different day.
Code module:
Option Explicit
Sub w_test()
Dim initialDate As Date
Dim finaldate As Date
initialDate = #5/5/2015#
finaldate = #9/29/2017#
Dim weeks As Variant
weeks = WeekNumbers(initialDate, finaldate)
Debug.Print "There are " & UBound(weeks, 1) & " weeks between " & _
Format(initialDate, "dd-mmm-yyyy") & " and " & _
Format(finaldate, "dd-mmm-yyyy")
End Sub
Private Function WeekNumbers(ByVal initialDate As Date, _
ByVal finaldate As Date, _
Optional ByVal weekStart As VbDayOfWeek = vbSunday) As Variant
Dim numberOfWeeks As Long
numberOfWeeks = DateDiff("ww", initialDate, finaldate, weekStart, vbFirstFullWeek)
Dim startOfWeek As Date
If Weekday(initialDate) <> vbSunday Then
Dim adjustBy As Long
If Weekday(initialDate) > weekStart Then
adjustBy = Weekday(initialDate) - weekStart
Else
adjustBy = (Weekday(initialDate) + 7) - weekStart
End If
startOfWeek = DateAdd("d", -adjustBy, initialDate)
End If
Dim allTheWeeks As Variant
ReDim allTheWeeks(1 To numberOfWeeks)
Dim weekInfo As Variant
ReDim weekInfo(1 To 3)
Dim i As Long
For i = 1 To numberOfWeeks
weekInfo(1) = startOfWeek
weekInfo(2) = DatePart("ww", startOfWeek, weekStart, vbFirstFourDays)
weekInfo(3) = Year(startOfWeek)
allTheWeeks(i) = weekInfo
startOfWeek = DateAdd("ww", 1, startOfWeek)
Next i
WeekNumbers = allTheWeeks
End Function
I have a document with the following:
FullDateTime FullDate FullTime Day Month Year Hour Minute Second
dd/mm/yyyy hh:mm:ss AM/PM
and I would like to fill in the other columns using macros to split the first column and place the whole date, whole time, day, month, year, hour, minute and second in the other columns. FullDateTime is every five minutes and I want to the DateTime to run for a whole year. I imagine the code to look something like:
Sub Func()
Dim 5mindays as Integer = 12*24*365
Dim x As Integer
Dim date
Dim time
For x = 1 To 5mindays
Split(," ")
Split(,"/")
Split(,":")
.Offset(0,1) = date(0)
...
.Offset(0,8) = time(2)
Add the next FullDateTime field below the existing one (adding 5 minutes)
Next
But have no idea how to actually do it. Please give me some ideas on how to solve this. Thanks!
Try after setting the correct worksheet name and year to process,
Option Explicit
Sub funk()
Dim dt As Long, yr As Long, tm As Long, dttm As Double
yr = 2018
dt = DateSerial(yr, 1, 1)
With Worksheets("sheet6")
Do While Year(dt) = yr
Do While TimeSerial(0, tm * 5, 0) < 1
dttm = dt + TimeSerial(0, tm * 5, 0)
.Cells(tm + 1 + (dt - DateSerial(yr, 1, 1)) * 288, "A").Resize(1, 9) = _
Array(dttm, dt, dttm - dt, _
Day(dt), Month(dt), yr, _
Hour(dttm), Minute(dttm), 0)
tm = tm + 1
Loop
tm = 0
dt = dt + 1
Loop
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "I").End(xlUp))
.Columns("A").NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
.Columns("B").NumberFormat = "dd/mm/yyyy"
.Columns("C").NumberFormat = "hh:mm:ss"
.Columns("D:I").NumberFormat = "0"
End With
End With
End Sub
I'm trying to calculate the time elapsed with the total amount of months, Days and Hours together using Datediff function. Is it not possible?
DateDiff("d hh", datein, Now)
What can I do?
That's not possible as the interval parameter can only be a single string.
You will have to do a bit more work like get the difference in hours and if it's above 24 convert the part before decimal separator into days
Sub Main()
Dim d1 As Date
d1 = "15/10/2014 08:00:03"
Dim d2 As Date
d2 = Now
Dim hrsDiff As Long
hrsDiff = DateDiff("h", d1, d2)
MsgBox IIf(hrsDiff >= 24, _
hrsDiff \ 24 & " days " & hrsDiff Mod 24 & " hours", _
hrsDiff & " hours")
End Sub
This is rough and ready, but is just directional. You could make a user defined function. This one returns 1:2:22:15 as a string (but you could return a custom class instance with variables for months, days, hours, minutes). It doesn't account for date2 being before date1 (not sure what happens then), nor does it account for date1 only being a partial day (assumes date1 is midnight).
Function MyDateDiff(date1 As Date, date2 As Date) As String
Dim intMonths As Integer
Dim datStartOfLastMonth As Date
Dim datStartOfLastHour As Date
Dim datEndOfMonth As Date
Dim intDays As Integer
Dim intHours As Integer
Dim intMinutes As Integer
Dim strResult As String
' Strip of any time
datStartOfLastMonth = DateSerial(Year(date2), Month(date2), Day(date2))
' check the dates arent in the same month
If Not ((Month(date1) = Month(date2) And Year(date1) = Year(date2))) Then
' how many months are there
intMonths = DateDiff("m", date1, date2)
Debug.Print (intMonths)
' how many days difference are there
intDays = DateDiff("d", DateAdd("m", intMonths, date1), date2)
Debug.Print (intDays)
' how many hours difference are there
intHours = DateDiff("h", datStartOfLastMonth, date2)
Debug.Print (intHours)
' how many minutes different are there
datStartOfLastHour = datStartOfLastMonth + (DatePart("h", date2) / 24)
intMinutes = DateDiff("n", datStartOfLastHour, date2)
Debug.Print (intMinutes)
Else
' Dates are in the same month
intMonths = 0
Debug.Print (intMonths)
' how many days difference are there
intDays = DateDiff("d", date1, date2)
Debug.Print (intDays)
' how many hours difference are there
intHours = DateDiff("h", datStartOfLastMonth, date2)
Debug.Print (intHours)
' how many minutes different are there
datStartOfLastHour = datStartOfLastMonth + (DatePart("h", date2) / 24)
intMinutes = DateDiff("n", datStartOfLastHour, date2)
Debug.Print (intMinutes)
End If
strResult = intMonths & ":" & intDays & ":" & intHours & ":" & intMinutes
MyDateDiff = strResult
End Function
Testing this:
?MyDateDiff("01-SEP-2014", "03-Oct-2014 22:15:33")
Gives:
1:2:22:15
i.e. 1 month, 2 days, 22 minutes and 15 seconds.
Reverse testing this by adding the components back onto date1 gives:
?DateAdd("n",15,DateAdd("h",22,DateAdd("d",2,DateAdd("m",1,"01-SEP-2014"))))
= "03-Oct-2014 22:15:33"
If we try with 2 dates in the same month:
?MyDateDiff("01-SEP-2014", "03-SEP-2014 22:15:33")
We get:
0:2:22:15
Reverse testing this:
?DateAdd("n",15,DateAdd("h",22,DateAdd("d",2,DateAdd("m",0,"01-SEP-2014"))))
Gives:
03/09/2014 22:15:00
But you may want to account for dates being the wrong way round...and you may only want date1 to be counted as a partial date if it starts later in the day....as I say, just a thought.
Regards
i
This may give you some ideas to correct for days in month or leap year Feb
Private Sub CommandButton1_Click()
DoDateA
End Sub
Sub DoDateA()
Dim D1 As Date, D2 As Date, DC As Date, DS As Date
Dim CA: CA = Array("", "yyyy", "m", "d", "h", "n", "s", "s")
Dim Va%(7), Da(7) As Date, Ci%
D1 = Now + Rnd() * 420 ' vary the * factors for range of dates
D2 = Now + Rnd() * 156
If D1 > D2 Then
[b4] = "Larger"
Else
[b4] = " smaller"
DS = D1
D1 = D2
D2 = DS
End If
[d4] = D1
[e4] = D2
DC = D2
For Ci = 1 To 6
Va(Ci) = DateDiff(CA(Ci), DC, D1)
DC = DateAdd(CA(Ci), Va(Ci), DC)
Va(Ci + 1) = DateDiff(CA(Ci + 1), DC, D1)
If Va(Ci + 1) < 0 Then ' added too much
Va(Ci) = Va(Ci) - 1
DC = DateAdd(CA(Ci), -1, DC)
Cells(9, Ci + 3) = Va(Ci + 1)
Cells(8, Ci + 3) = Format(DC, "yyyy:mm:dd hh:mm:ss")
End If
Da(Ci) = DC
Cells(5, Ci + 3) = CA(Ci)
Cells(6, Ci + 3) = Va(Ci)
Cells(7, Ci + 3) = Format(Da(Ci), "yyyy:mm:dd hh:mm:ss")
Cells(10, Ci + 3) = DateDiff(CA(Ci), D2, D1)
Next Ci
End Sub