At the begging I want tell you that I just read a lot of stack's about it and I didnt find solution so...
I'm substracting two dates
1 - 2017/05/05 17:00
2 - 2017/05/09 18:00
I want to receive "4 Days 1 Hour"
How I should do it? I tried to use DateFormat/Format/DateDiff and a lot of things.
It doesn't always have to be a ready-made VBA function. Especially with dates, I rarely find what I want exactly as VBA-ready. Try this custom function:
Function myDateDiff(ByVal d1 As Date, ByVal d2 As Date) As String
Dim days As Long, hours As Long
days = DateDiff("d", d1, d2) ' diff in days
hours = DateDiff("h", d1, d2) - days * 24 ' diff in hours
myDateDiff = days & " Day" & IIf(days > 1, "s ", " ") & hours & " Hour" & IIf(hours > 1, "s", "")
End Function
Sub Test()
Dim d1 As Date, d2 As Date
d1 = CDate("2017/05/05 17:00")
d2 = CDate("2017/05/09 18:00")
Debug.Print myDateDiff(d1, d2) ' 4 Days 1 Hour
d1 = CDate("2017/05/05 17:00")
d2 = CDate("2017/05/06 19:00")
Debug.Print myDateDiff(d1, d2) ' 1 Day 2 Hours
End Sub
Related
First of all, I'm a beginner and still learning VBA, thank you for your consideration.
I have a CalcWorkingDays function which which calculates working days within a specific period (period defined by a query parameter).
But when it returns results, for some periods it is completely correct, and for some others it's incorrect (See example at the end)
I guess the problem is in these lines :
If Format(DateCnt, "w") <> "7" And _
Format(DateCnt, "w") <> "6" Then
Thank you !
Public Function CalcWorkingDays(BegDate As Variant, EndDate As Variant) As Integer
Dim WholeWeeks As Variant
Dim DateCnt As Variant
Dim EndDays As Integer
On Error GoTo Err_Work_Days
BegDate = DateValue(BegDate)
EndDate = DateValue(EndDate)
WholeWeeks = DateDiff("w", BegDate, EndDate)
DateCnt = DateAdd("ww", WholeWeeks, BegDate)
EndDays = 0
Do While DateCnt <= EndDate
If Format(DateCnt, "w") <> "7" And _
Format(DateCnt, "w") <> "6" Then
EndDays = EndDays + 1
End If
DateCnt = DateAdd("d", 1, DateCnt)
Loop
CalcWorkingDays = WholeWeeks * 5 + EndDays
Exit Function
[...]
End Function`
For example, on march 2019.
there is a total of 21 working days. We have both employees A and B
A : he's on a project from 01/01/2019 to 31/12/2019, the function gives me 21 working days for march which is correct
B : He's been assigned to a project from 01/03/2019 to 08/03/2019, it gives me 5 which is incorrect, it should give me 6 (8 total days days - 2 days for week end
Harassed Dad is right - if you use Format(DateCnt, "w"), Sunday will be "1", Monday "2"...
But you shouldn't use Format to get the day of the week - Format is for formatting data into strings, and there is no need to involve strings. Use the Weekday-function instead.
The default behavior for Weekday is that Sunday will be 1 (as a number, not a string), but you can change that with the 2nd parameter (FirstDayOfWeek). This defines which day you want to have as first day of the week.
So you can change your logic for example to
If Weekday(DateCnt, vbMonday) < 6 Then
Date arithmetic is tricky. If you are not hugely concerned about efficiency and your intervals are relatively small then a really simple function will do the trick
Public Function CalcWorkingDays(BegDate As Variant, EndDate As Variant) As Integer
CalcWorkingDays = 0
For i = begdate To enddate
If Weekday(i, vbMonday) <= 5 Then
CalcWorkingDays = CalcWorkingDays + 1
End If
Next
End Function
Not particularly elegant but effective, easy to understand, and easy to modify.
The function gives me 21 working days for march which is correct B
He's been assigned to a project from 01/03/2019 to 08/03/2019, it
gives me 5 which is incorrect, it should give me 6.
A diff-function will never include the last date. If you wish to include that last date, add one day to the last date before calculating:
? DateDiffWorkDays(#2019/03/01#, #2019/03/31#)
21
? DateDiffWorkDays(#2019/03/01#, #2019/04/01#)
21
? DateDiffWorkDays(#2019/03/01#, #2019/03/08#)
5
? DateDiffWorkDays(#2019/03/01#, #2019/03/09#)
6
Also, as already noted, specify Monday as the first day of the week. Further, don't use Format; Weekday is the "direct" method. Thus:
If Weekday(DateCnt, vbMonday) < 6 Then
EndDays = EndDays + 1
End If
For an extended method that takes holidays into account, study my functions:
Option Compare Database
Option Explicit
' Returns the count of full workdays between Date1 and Date2.
' The date difference can be positive, zero, or negative.
' Optionally, if WorkOnHolidays is True, holidays are regarded as workdays.
'
' Note that if one date is in a weekend and the other is not, the reverse
' count will differ by one, because the first date never is included in the count:
'
' Mo Tu We Th Fr Sa Su Su Sa Fr Th We Tu Mo
' 0 1 2 3 4 4 4 0 0 -1 -2 -3 -4 -5
'
' Su Mo Tu We Th Fr Sa Sa Fr Th We Tu Mo Su
' 0 1 2 3 4 5 5 0 -1 -2 -3 -4 -5 -5
'
' Sa Su Mo Tu We Th Fr Fr Th We Tu Mo Su Sa
' 0 0 1 2 3 4 5 0 -1 -2 -3 -4 -4 -4
'
' Fr Sa Su Mo Tu We Th Th We Tu Mo Su Sa Fr
' 0 0 0 1 2 3 4 0 -1 -2 -3 -3 -3 -4
'
' Execution time for finding working days of three years is about 4 ms.
'
' Requires table Holiday with list of holidays.
'
' 2015-12-19. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function DateDiffWorkdays( _
ByVal Date1 As Date, _
ByVal Date2 As Date, _
Optional ByVal WorkOnHolidays As Boolean) _
As Long
Dim Holidays() As Date
Dim Diff As Long
Dim Sign As Long
Dim NextHoliday As Long
Dim LastHoliday As Long
Sign = Sgn(DateDiff("d", Date1, Date2))
If Sign <> 0 Then
If WorkOnHolidays = True Then
' Holidays are workdays.
Else
' Retrieve array with holidays between Date1 and Date2.
Holidays = GetHolidays(Date1, Date2, False) 'CBool(Sign < 0))
' Ignore error when using LBound and UBound on an unassigned array.
On Error Resume Next
NextHoliday = LBound(Holidays)
LastHoliday = UBound(Holidays)
' If Err.Number > 0 there are no holidays between Date1 and Date2.
If Err.Number > 0 Then
WorkOnHolidays = True
End If
On Error GoTo 0
End If
' Loop to sum up workdays.
Do Until DateDiff("d", Date1, Date2) = 0
Select Case Weekday(Date1)
Case vbSaturday, vbSunday
' Skip weekend.
Case Else
If WorkOnHolidays = False Then
' Check for holidays to skip.
If NextHoliday <= LastHoliday Then
' First, check if NextHoliday hasn't been advanced.
If NextHoliday < LastHoliday Then
If Sgn(DateDiff("d", Date1, Holidays(NextHoliday))) = -Sign Then
' Weekend hasn't advanced NextHoliday.
NextHoliday = NextHoliday + 1
End If
End If
' Then, check if Date1 has reached a holiday.
If DateDiff("d", Date1, Holidays(NextHoliday)) = 0 Then
' This Date1 hits a holiday.
' Subtract one day to neutralize the one
' being added at the end of the loop.
Diff = Diff - Sign
' Adjust to the next holiday to check.
NextHoliday = NextHoliday + 1
End If
End If
End If
Diff = Diff + Sign
End Select
' Advance Date1.
Date1 = DateAdd("d", Sign, Date1)
Loop
End If
DateDiffWorkdays = Diff
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 Function
You'll see, that in its core it's nothing but a simple loop, which is so fast that attempts to optimise won't pay off for typical usage.
Maybe you try to use function networkdays
=NETWORKDAYS(start_date,end_date,holidays)
holidays is optional
For example, if you have the date January 4, 2016 (a Monday) in cell B4, and January 11, 2016 (also a Monday) in cell C4, this formula will return 6:
=NETWORKDAYS(B4,C4)
for VBA in ACCESS
Sub test()
Dim xl As Object
Set xl = CreateObject("Excel.Application")
BegDate = #4/11/2019#
EndDate = #6/11/2019#
result = xl.WorksheetFunction.NetworkDays(BegDate, EndDate) ' 44
Set xl = Nothing
End Sub
OR
this one
I want to calculate the difference in hh:mm:ss between Now and column E. They both appear in format dd/mm/yyyy hh:mm. With the code I have written below, it only takes into consideration the hh:mm and not the days. So, if they have 2 days difference in wont add to the hours +48. The code is below:
With ws1.Range("N2:N" & lastrow1)
.Formula = "=TIME(HOUR(NOW()),MINUTE(NOW()),SECOND(NOW()))-TIME(HOUR(E2),MINUTE(E2),SECOND(32))"
End With
Just use =(NOW()-E2) and apply a custom format [hh]:mm:ss. The brackets around hh will do the trick.
If you rather need a number of hours, multiply by 24 as #Kerry Jackson suggested.
The logic behing date/time values is that 1 day = 1, so
1 hour = 1/24
1 min = 1/1440 '(that is 24*60 )
etc...
Put this in a module
Public Function DateTimeDiff(d1 As Date, d2 As Date)
Dim diff As Double
diff = ABS(d2 - d1)
DateTimeDiff = Fix(diff) & Format(diff, " hh:mm")
End Function
Then use
=DateTimeDiff( NOW(), E2 )
as the formula in the worksheet.
You might want to add some validation on the dates and return an error message if they are not valid.
Are you looking for a number which is the number of hours, or are you looking for text?
If you want the number of hours, try just subtracting the dates, and multiplying by 24, so the formula would be =(NOW()-E2)*24.
Public Function timeElapsed(ByVal target_cell As Range) As String
Dim hours As Long, minutes As Long, days As Long
If target_cell.Value = 0 Then Exit Function
x = DateDiff("n", target_cell, Now())
days = Format(Application.WorksheetFunction.RoundDown(x / 1440, 0), "00")
hours = Format(Application.WorksheetFunction.RoundDown((x - (days * 1440)) / 60, 0), "00")
minutes = Format(Application.WorksheetFunction.RoundDown((x - ((days * 1440) + (hours * 60))), 0), "00")
timeElapsed = CStr(days) & " " & "days" & " " & CStr(hours) & ":" & CStr(minutes)
End Function
And use as function with the result as below:
So you code becomes:
With ws1
.Range("N2:N" & lastrow1).FormulaR1C1 = "=timeElapsed(RC[-9])"
End With
I have to query reports based on the time given by me.
There are 4 slots of time: 0, 15, 30, 45.
Foe example, if the current time is 13:44, I will use time as 13:15 to 13:30 to query my reports; and if the current time is 13:04, I will use time as 12:30 to 13:45 to query my reports.
I have written the following code, but it uses lots of If and Else. Please help me with some better code.
Sub Test()
hh = Format(Time, "hh")
mm = Format(Time, "mm")
If (0 < mm < 15) Then mm = mm - 30
If (15 < mm < 30) Then mm = mm - 30
If (30 < mm < 45) Then mm = mm - 30
If (45 < mm < 60) Then mm = mm - 30
If (mm < 0) Then
mm = -mm
hr = hr - 1
End If
st = hh & "&" & mm
End Sub
You can use a little maths to round down to specific interval or bring the worksheet FLOOR function into play.
Option Explicit
Sub Test()
Dim tm As Double, st As String
tm = Application.Floor(Time, TimeSerial(0, 15, 0))
st = Format(tm, "hh\&mm")
Debug.Print st
End Sub
This is the follow up post of this question and this question
I have created the following VBA function to calculate the seconds(also count the milliseconds) from two datetime.
Function:
Public Function ConvertDate(D1 As String, D2 As String) As Date
Dim StrD1 As Date
Dim StrD2 As Date
StrD1 = CDate(Left(D1, 10) & " " & Replace(Mid(D1, 12, 8), ".", ":"))
StrD2 = CDate(Left(D2, 10) & " " & Replace(Mid(D2, 12, 8), ".", ":"))
ConvertDate = DateDiff("s", StrD2, StrD1)
End Function
Scenario 1:
Given Dates:
2011-05-13-04.36.14.366004
2011-05-13-04.36.14.366005
Getting Result:
0
Expected Result:
0.000001
Scenario 2:
Given Dates:
2011-05-13-04.36.14.366004
2011-05-13-04.36.15.366005
Getting Result:
1
Expected Result:
1.000001
Scenario 3:
Given Dates:
2011-05-13-04.36.14.366004
2011-05-13-04.37.14.366005
Getting Result:
60
Expected Result:
60.000001
A day is 1. A date is 1 for every day past 31-Dec-1899. Today happens to be 42,556. Time is a decimal portion os a day. Today at noon will be 42,556.5 and today at 06:00 pm will be 42,556.75.
There are 24 hours in a day, 60 minutes in an hour and 60 seconds in a minute. That means that there are 86,400 seconds in a day (24 × 60 × 60) and a second is ¹⁄₈₆₄₀₀ (0.0000115740740740741) of a day. Excel's 15 digit floating point calculation sometimes fouls up (loses small amounts) time calculations due to the base-24 and base-60 numbering system.
Dim tm1 As String, tm2 As String
Dim dbl1 As Double, dbl2 As Double
Dim i As Long
With Worksheets("Sheet9")
For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row Step 2
tm1 = .Cells(i, "A").Text
tm2 = .Cells(i + 1, "A").Text
dbl1 = CLng(CDate(Left(tm1, 10))) + _
TimeValue(Replace(Mid(tm1, 12, 8), Chr(46), Chr(58))) + _
(CDbl(Mid(tm1, 20)) / 86400)
dbl2 = CLng(CDate(Left(tm2, 10))) + _
TimeValue(Replace(Mid(tm2, 12, 8), Chr(46), Chr(58))) + _
(CDbl(Mid(tm2, 20)) / 86400)
.Cells(i + 1, "B") = (dbl2 - dbl1) * 86400
.Cells(i + 1, "B").NumberFormat = "0.000000"
Next i
End With
The above takes your time-and-date-as-text and calculates a pseudo-DateDiff to an accuracy of a millionth of a second. The results are displayed in seconds as an integer with fractions of a second as a decimal.
I need to return the exact difference between two dates in the form of a string.
If the dates are 01-FEB-2012 and 01-FEB-2014, the function should return "2 years".
If the dates are 01-FEB-2012 and 01-MAR-2014, the function should return "25 months".
If the difference is not in exact years or months, it should return the difference in days.
I do not want to use DateDiff from the Visual Basic namespace so the code is portable to C#.
'Assuming d1 < d2
Public Function GetDateDiff(d1 as DateTime, d2 As DateTime) As String
If d1.Day = d2.Day Then
Dim yearDiff As Integer = d2.Year - d1.Year
If d1.Month = d2.Month Then
'Only year differs
Return yearDiff & " years"
Else
'Month and year differs
Dim monthDiff As Integer = d2.Month - d1.Month
Return (yearDiff * 12 + monthDiff) & " months"
End If
Else
Return (d2-d1).TotalDays & " days"
End If
End Function