I am trying to do a simple date difference calculation that returns a Year and Month value. The code the I have now is:
Private Sub Form_AfterUpdate()
Dim IntegerYears As Long
Dim IntegerMonths As Long
IntegerYears = DateDiff("yyyy", Me.DeemedFilingDate, Now())
IntegerMonths = DateDiff("m", Me.DeemedFilingDate - IntegerYears, Now())
Me.TimeElapsedFromFilingDate = IntegerYears & " Yr(s)." & " " & "," & " " & IntegerMonths & " Mo(s)."
End Sub
At this point, I am getting an output in year/month format, but it's not correct. I am getting negative numbers, the month count goes above 12 months, and the year shows 1 year when the start date is in the previous year but a year hasn't necessarily passed. For instance, the code will return 1 year if the start date is 12/1/2017 and the current date is 3/2/2018 instead of just returning 3 months.
You're doing multiple unusual things. Let me walk you through them:
You've declared TimeElapsed as a double, but you're setting it equal to the result of DateDiff, which returns a Variant(Long)
Dim TimeElapsed As Long
You need to use string delimiters in your DateDiff for the first argument. Also, it's lower case y, not upper case:
TimeElapsed = DateDiff("yyyy", Now(), Me.DeemedFilingDate)
This line:
IntegerMonths = Round(TimeElapsed - IntegerYears) * 12
Makes no sense to me. You're taking the time elapsed, removing the time difference between then and now in years, then rounding it, and then multiplying it by 12?
You probably want the following instead:
IntegerMonths = DateDiff("m", Now(), Me.DeemedFilingDate - TimeElapsed)
Also, VBA doesn't really do integers. All integers in VBA are really longs that get cast to an integer as needed. Using a long is more efficient, and doesn't take more memory.
Final result:
Private Sub Form_AfterUpdate()
Dim IntegerYears As Long
Dim IntegerMonths As Long
IntegerYears = DateDiff("yyyy", Now(), Me.DeemedFilingDate)
IntegerMonths = DateDiff("m", DateAdd("yyyy", IntegerYears *-1, Now()), Me.DeemedFilingDate)
Me.TimeElapsedFromFilingDate = IntegerYears & " Years " & IntegerMonths & " Months"
End Sub
Resolved:
Private Sub Form_AfterUpdate()
Dim TimeElapsedMonths As Integer
Dim TimeElapsedYears As Integer
Dim TimeElapsedRemMonths As Integer
TimeElapsedMonths = DateDiff("m", Me.DeemedFilingDate, Now())
TimeElapsedRemMonths = TimeElapsedMonths Mod 12
TimeElapsedYears = Int(TimeElapsedMonths / 12)
Me.TimeElapsedFromFilingDate = TimeElapsedYears & " Yr(s)." & "," & " " &
TimeElapsedRemMonths & " Mo(s)."
End Sub
Related
I am trying to develop VBA code that yields the accurate number of months and remaining days between two dates.
The test dates to be used are the following:
Date1: 04/19/1995
Date2: 12/26/22
The correct answer per: https://www.calculator.net/date-calculator.html is: 332 months 7 days
The correct answer generated per my VBA code below is: 332 months 3 days.
Can anyone shed some light as to why this is the case?
Private Sub CommandButton7_Click()
' Calculate the difference between two dates in months and remaining days
Dim startDate As Date
Dim endDate As Date
Dim months As Long
Dim days As Long
startDate = Application.InputBox("Enter a date:", "Date Input 1", Date, Type:=2)
endDate = Application.InputBox("Enter another date:", "Date Input 2", Date, Type:=2)
months = Abs(DateDiff("m", startDate, endDate))
days = Abs(DateDiff("d", startDate, endDate)) Mod 30
MsgBox "The difference between the two dates is: " & months & " months and " & days & " days."
End Sub
Yes. The following line in your code -
days = Abs(DateDiff("d", startDate, endDate)) Mod 30
assumes that all months have 30 days. They do not!
It is not that simple because of the varying count of days of the months. You have to use DateAdd to obtain the correct month count.
This function does it right:
' Returns the difference in full months from DateOfBirth to current date,
' optionally to another date.
' Returns by reference the difference in days.
' Returns zero if AnotherDate is earlier than DateOfBirth.
'
' Calculates correctly for:
' leap Months
' dates of 29. February
' date/time values with embedded time values
' any date/time value of data type Date
'
' DateAdd() is, when adding a count of months to dates of 31th (29th),
' used for check for month end as it correctly returns the 30th (28th)
' when the resulting month has 30 or less days.
'
' 2015-11-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function AgeMonthsDays( _
ByVal DateOfBirth As Date, _
Optional ByVal AnotherDate As Variant, _
Optional ByRef Days As Integer) _
As Long
Dim ThisDate As Date
Dim Months As Long
If IsDateExt(AnotherDate) Then
ThisDate = CDate(AnotherDate)
Else
ThisDate = Date
End If
' Find difference in calendar Months.
Months = DateDiff("m", DateOfBirth, ThisDate)
If Months < 0 Then
Months = 0
Else
If Months > 0 Then
' Decrease by 1 if current date is earlier than birthday of current year
' using DateDiff to ignore a time portion of DateOfBirth.
If DateDiff("d", ThisDate, DateAdd("m", Months, DateOfBirth)) > 0 Then
Months = Months - 1
End If
End If
' Find difference in days.
Days = DateDiff("d", DateAdd("m", Months, DateOfBirth), ThisDate)
End If
AgeMonthsDays = Months
End Function
Example (in the immidiate pane):
Days% = 0
? AgeMonthsDays(#04/19/1995#, #12/26/2022#, Days%), Days%
332 7
It is from my library at GitHub: VBA.Date.
Date Difference in Months and Days
The Button Code
Private Sub CommandButton7_Click()
DateDifference
End Sub
The Main Method
Sub DateDifference()
' Calculates the difference between two dates in months and days.
' Define constants.
Const PROC_TITLE As String = "Date Difference"
Dim Prompts(): Prompts = VBA.Array("Enter a date:", "Enter another date:")
Dim Titles(): Titles = VBA.Array("Date Input 1", "Date Input 2")
' Get the input using the 'GetInputDate' function.
Dim InputValue As Variant
Dim Dates(0 To 1) As Date
Dim d As Long
For d = 0 To 1
InputValue = GetInputDate(Prompts(d), Titles(d))
If IsEmpty(InputValue) Then Exit Sub
Dates(d) = CDate(InputValue)
Next d
' Determine the Start and End date ('Start <= End').
Dim StartDate As Date, EndDate As Date
If Dates(0) < Dates(1) Then
StartDate = Dates(0)
EndDate = Dates(1)
Else
StartDate = Dates(1)
EndDate = Dates(0)
End If
' Calculate the difference.
Dim Months As Long: Months = DateDiff("m", StartDate, EndDate)
Dim MonthDate As Date: MonthDate = DateAdd("m", Months, StartDate)
Dim Days As Long: Days = DateDiff("d", MonthDate, EndDate)
' Inform.
Dim Msg As String: Msg = "The difference between the two dates is " _
& IIf(Months = 1, "one month", Months & " months") & " and " _
& IIf(Days = 1, "one day", Days & " days") & "."
MsgBox Msg, vbInformation, PROC_TITLE
End Sub
A Helper Function
Function GetInputDate( _
ByVal Prompt As String, _
ByVal Title As String) _
As Variant ' a date or 'Empty'
Const PROC_TITLE As String = "Get Input Date"
Dim InputValue As Variant, MsgAnswer As Long, Msg As String
Do
InputValue = Application.InputBox(Prompt, Title, Date, , , , , 2)
If VarType(InputValue) = vbBoolean Then
MsgBox "Canceled.", vbExclamation, PROC_TITLE
Exit Function
End If
If IsDate(InputValue) Then GetInputDate = InputValue: Exit Function
Msg = "The string """ & InputValue & """ can't be converted " _
& "to a date. Do you want to try again?"
MsgAnswer = MsgBox(Msg, vbYesNo + vbQuestion, PROC_TITLE)
If MsgAnswer = vbNo Then Exit Function
Loop
End Function
I have below dates in an Excel column, as you can see.
Sprint 1 takes from 10.04 to 21.04 this means 2 weeks and between brackets they are specified week 15 and 16 which is correct but for Sprint 2, who also starts in 10.04 but takes until 05.05 it means 7 weeks, but are displayed also the weeks from the Sprint1.
"Sprint1 (CW15-16/2017)
[10.04.2017 - 21.04.2017]
Sprint2 (CW15-16/2017)
[10.04.2017 - 05.05.2017]"
What I have until now is:
'reading the first CW of the sprint based on the date
SprintFristCW = Left(planning_wb.Worksheets(SprintPlanningTable).Cells(2, i + 1).Value, 9)
'reading the last CW of the Sprint based on the date
SprintEndCW = Right(planning_wb.Worksheets(SprintPlanningTable).Cells(2, i + Sprintlength).Value, 9)
SprintCW = Left(SprintFirstCW, 4) & "-" & Right(SprintEndCW, 7)
But SprintEndCW is not reading correct the week number.
So I need to read the correct week number in which each sprint ends and print it.
Don't create huge procedures. Small is beautiful. Create functions that feed into your Main procedure. Here is an example. The procedure TestExtraction calls the function ExtractWeeks. Therefore ExtractWeeks needs not be part of the procedure that calls it, making the code easier to understand and maintain.
Private Sub TestExtraction()
Dim Fun As Long
Dim DateString As String
Dim StartDate As Date, EndDate As Date
DateString = ActiveCell.Value
' the DateString is re-defined here for testing purposes
DateString = "[10.04.2017 - 05.05.2017]"
Fun = ExtractWeeks(DateString, StartDate, EndDate)
If Fun < 0 Then
Debug.Print "Invalid date"
Else
With Application
DateString = "(CW" & .WeekNum(StartDate)
If Year(StartDate) <> Year(EndDate) Then _
DateString = DateString & "/" & Year(StartDate)
DateString = DateString & " - " & .WeekNum(EndDate) & "/" & Year(EndDate) & ")"
End With
Debug.Print DateString
Debug.Print Fun & " weeks"
End If
End Sub
Private Function ExtractWeeks(ByVal DateString As String, _
StartDate As Date, _
EndDate As Date) As Long
' 24 Oct 2017
' return the number of weeks between dates (rounded up)
' return -1 if one of the dates is unreadable
Dim Dates() As String
Dim i As Integer
Dates = Split(Mid(DateString, 2, Len(DateString) - 2), "-")
On Error Resume Next
For i = 0 To 1
Dates(i) = Replace(Trim(Dates(i)), ".", Application.International(xlDateSeparator))
Next i
StartDate = DateValue(Dates(0))
EndDate = DateValue(Dates(1))
If Err Then
ExtractWeeks = -1
Else
ExtractWeeks = Int((StartDate - EndDate) / 7) * -1
End If
End Function
The point is that not everything that looks like a date is a date Excel can understand. The Function ExtractWeeks converts the "dates' from your worksheet into real dates and returns these dates to the calling procedure. It also returns -1 in case of error which you can use to trap such errors. In my example, the function returns the number of weeks (or -1). You might let it return the CW string my calling procedure constructs. You will find it easy to move the process of constructing that string to the function and let the function return "" in case of error instead of -1. Perhaps you can exclude the possibility of errors in the dates. This is a question of how you integrate the function into your Main.
I would like to ask if in VBA there is a built in function which will parse a date object from a string based on a specified format.
For example:
dateString = "24-4-12"
VBADateFunc(dateString, "dd-m-yy")
to return a date object interpreting the dateString string by the provided format.
I will appretiate your ideas on this.
Thank you
Here you go:
Public Sub TestMe()
Dim dtMyDate As Date
dtMyDate = Format("24-4-12", "dd-mm-yy")
Debug.Print dtMyDate
Debug.Print Format(dtMyDate, "yyyy")
Debug.Print Format(dtMyDate, "dd-mmm-yy")
'For Non-Europeans:
dtMyDate = Format(DateSerial(2012, 4, 24), "dd-mm-yy")
Debug.Print dtMyDate
Debug.Print Format(dtMyDate, "yyyy")
Debug.Print Format(dtMyDate, "dd-mmm-yy")
End Sub
From the comments - in general, the date is a long value in MS Excel and VBA. Today's date can be seen like this in the immediate window:
?clng(now)
42935
If you want to do further something with the 42935 value, you may go like this:
?Format(42934,"dd-mm-yyyy")
Note: Today is 42934 for all those, who have ActiveWorkbook.Date1904 = False. For those, who are starting the calendar with 1904, today is 42935-4*365-1
I ended up writing my own function to scan a date. Leaving out error handling:
Function ScanDate(s As String, Optional order As String = "DMY", Optional separator As String = "-") As Date
Dim parts() As String
parts = Split(s, separator)
Dim day As Long, month As Long, year As Long
day = parts(InStr(order, "D") - 1)
month = parts(InStr(order, "M") - 1)
year = parts(InStr(order, "Y") - 1)
ScanDate = DateSerial(year, month, day)
End Function
I am trying to make a small helper app to assist in reading SCCM logs. Parsing the dates has been pretty straightforward until I get to the timezone offset. It is usually in the form of "+???". literal example: "11-01-2016 11:44:25.630+480"
DateTime.parse() handles this well most of the time. But occasionally I run into a time stamp that throws an exception. I cannot figure out why. This is where I need help. See example code below:
Dim dateA As DateTime = Nothing
Dim dateB As DateTime = Nothing
Dim dateStr_A As String = "11-07-2016 16:43:51.541+600"
Dim dateStr_B As String = "11-01-2016 11:44:25.630+480"
dateA = DateTime.Parse(dateStr_A)
dateB = DateTime.Parse(dateStr_B)
MsgBox(dateA.ToString & vbCrLf & dateB.ToString)
IF run it would seem dateStr_B is an invalid time stamp? Why is this? I've tried to figure out how to handle the +480 using the 'zzz' using .ParseExact() format as shown here Date Formatting MSDN
Am I missing something with the timezone offset? I've searched high and low but these SCCM logs seem to use a non standard way of representing the offset. Any insight would be greatly appreciated
The problem is that +480 is indeed an invalid offset. The format of the offset from UTC (as produced when using the "zzz" Custom Format Specifier) is hours and minutes. +600 is 6 hours and 0 minutes ahead of UTC, which is valid. +480 would be 4 hours and 80 minutes ahead of UTC, which is invalid as the number of minutes can't be more than 59.
If you have some external source of date and time strings that uses an offset that is simply a number of minutes (i.e. +600 means 10 hours and +480 means 8 hours), you will need to adjust the offset before using DateTime.Parse or DateTime.ParseExact.
[Edit]
The following function takes a timestamp with a positive or negative offset (of any number of digits) in minutes, and returns a DateTime. It throws an ArgumentException if the timestamp is not in a valid format.
Public Function DateTimeFromSCCM(ByVal ts As String) As DateTime
Dim pos As Integer = ts.LastIndexOfAny({"+"c, "-"c})
If pos < 0 Then Throw New ArgumentException("Timestamp must contain a timezone offset", "ts")
Dim offset As Integer
If Not Integer.TryParse(ts.Substring(pos + 1), offset) Then
Throw New ArgumentException("Timezone offset is not numeric", "ts")
End If
Dim hours As Integer = offset \ 60
Dim minutes As Integer = offset Mod 60
Dim timestamp As String = ts.Substring(0, pos + 1) & hours.ToString & minutes.ToString("00")
Dim result As DateTime
If Not DateTime.TryParse(timestamp, result) Then
Throw New ArgumentException("Invalid timestamp", "ts")
End If
Return result
End Function
Thank you for the insight. I had a feeling I would need to handle this manually. I just wanted to make sure I wasn't missing something simple in the process. My knowledge of the date and time formatting is a bit lacking.
As such, I have altered my code so that it handles the offset. Granted I will have to add some more input validation in the final product.
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim dateA As DateTime = Nothing
Dim dateB As DateTime = Nothing
Dim dateStr_A As String = correctOffset("11-07-2016 16:43:51.541+600")
Dim dateStr_B As String = correctOffset("11-07-2016 16:43:51.541+480")
dateA = DateTime.Parse(dateStr_A)
dateB = DateTime.Parse(dateStr_B)
MsgBox(dateA.ToString & vbCrLf & dateB.ToString)
End Sub
Public Function correctOffset(ByVal ts As String)
Dim offset As Integer = CInt(ts.Substring(ts.Length - 3))
Dim offHour As Integer = offset / 60
Dim offMin As Integer = offset - (offHour * 60)
Dim strhour As String = Nothing
Dim strmin As String = Nothing
If offHour <= 9 Then
strhour = "0" & CStr(offHour)
Else
strhour = CStr(offHour)
End If
If offMin <= 9 Then
strmin = "0" & CStr(offMin)
Else
strmin = CStr(offMin)
End If
Return ts.Substring(0, ts.Length - 3) & strhour & ":" & strmin
End Function
I have data for a date that looks like this: "2015-02-11T19:41:50-08:00"
I would like to know if there is already a function that exists in VBA which can convert the above data to the format of something like "02/11/2015 11:41 AM PST"
I attempted the following code playing around with the format function but was unable to get VBA to recognize the format as a date:
testdate = "2015-02-12T22:57:05-08:00"
newdate = Format(testdate, "mm/dd/yyyy hh/nn/ss AM/PM")
Debug.Print newdate
The output was still "2015-02-12T22:57:05-08:00"
Thanks for the help.
Edit:
I was able to resolve the problem by taking your suggestions to use the mid() function since the dates are in fixed format. I decided to keep the military time in the final version.
Here is my code for anyone curious:
Function convertDate(orderdate)
'takes the date formatted as 2015-02-06T08:26:00-08:00
'and converts it to mm/dd/yyyy hh/nn/ss UTC format
'2015-02-06T08:26:00-08:00
orderyear = Mid(orderdate, 1, 4)
ordermonth = Mid(orderdate, 6, 2)
orderday = Mid(orderdate, 9, 2)
orderhour = Mid(orderdate, 12, 2)
orderminute = Mid(orderdate, 15, 2)
ordersecond = Mid(orderdate, 18, 2)
newdate = ordermonth & "/" & orderday & "/" & orderyear
newtime = orderhour & ":" & orderminute & ":" & ordersecond
'Debug.Print newdate
convertDate = newdate & " " & newtime & " UTC"
End Function
Because your input isn't a true date none of Excel or VBA's date methods will work with it. Your best bet is to break the string down into parts, work with them individually, and then join it all back up again - for example:
testdate = "2015-02-12T22:57:05-08:00"
'// The letter T is redundant, so let's split the string here into an array:
dateArr = Split(testdate, "T")
'// Part 1 of the array can be easily converted with CDate() and Format()
dateArr(0) = Format(CDate(dateArr(0)), "mm/dd/yyyy")
'// Part 2 of the array will need to be broken down further:
dateArr(1) = Format(TimeValue(Split(dateArr(1), "-")(0)) - _
TimeSerial(Left(Split(dateArr(1), "-")(1), 2), _
Right(Split(dateArr(1), "-")(1), 2), 0), "hh:mm:ss")
'// The above line does the following:
'// 1) Split the second part of the array again, using the "-" as the delimiter
'// 2) Convert the first part of this (22:57:05) to a time using TimeValue()
'// 3) Convert the second part (08:00) to hours & minutes using TimeSerial()
'// 4) Minus the latter from the former (which can only be done if both are a valid time)
'// 5) Wrap all that into a Format() method to show "hh:mm:ss" instead of a Double.
'// Join the two parts back together and add "PST" on the end.
newdate = Join(dateArr, " ") & " PST"
Debug.Print newdate
'// Output will display "02/12/2015 14:57:05 PST"
N.B. I have chosen not to include "AM" or "PM" because your time is in 24hr format anyway so I don't see the relevance...
It's not converting because of the "T" and because of the tacked on time range at the end. You can ditch the "T" and truncate off the trailing range and it will convert.
Public Sub Example()
Const testValue As String = "2015-02-12T22:57:05-08:00"
Dim dateValue As Date
Dim stringValue As String
Dim subVal As Date
Dim hyphenPos As Long
stringValue = testValue
Mid(stringValue, 11&, 1&) = " "
hyphenPos = InStrRev(stringValue, "-")
subVal = Mid$(stringValue, hyphenPos + 1&)
dateValue = CDate(Left$(stringValue, hyphenPos - 1&)) - subVal
End Sub
Couple of ideas:
The sample date you have 2015-02-12T22:57:05-08:00 is not a real date (I think)
I think the following will give you the closest format to what you are looking for (you will need to define the range.Range.NumberFormat = "[$-409]h:mm:ss AM/PM"
Your best bet is concating "PST" to a date datatype formatted to your needs.
Sub DebugPrintDate()
Dim testdate As Date: testdate = Now
newdate = Format(testdate, "mmm/dd/yyyy hh:mm AM/PM") & " PST"
Debug.Print newdate
End Sub
Ouput:
Never mind the "févr". My system locale is France.
If you want to define a particular date, make sure to wrap the date in two #s.
Example:
Dim someDateAndTime As Date = #8/13/2002 12:14 PM#