Reputation: 341
I need to calculate days and months between dates, ensuring accuracy when crossing month boundaries.
I assume Wolfram Alpha results are correct so I want the same results from my VBA code.
For example:
The difference between "31/03/1955" and "26/05/2024" should be:
The difference between "30/03/1955" and "26/05/2024" should be:
My code in this last case, starting date "30/03/1955" calculates:
Option Explicit
Public Function DiffDate44(ByVal data1 As Variant, ByVal data2 As Variant, dato_richiesto As String, valori_assoluti As Boolean) As Variant
Dim anni As Integer, mesi As Integer, giorni As Integer
Dim giorni_totali As Long
Dim dummy As Date, tempDate As Date
Dim anniStr As String, mesiStr As String, giorniStr As String, giorni_totaliStr As String, spaziatura As String
On Error GoTo ErrorHandler
' Convert inputs to Date type
data1 = CDate(data1)
data2 = CDate(data2)
' Handle absolute values if required
If valori_assoluti = True Then
If data1 > data2 Then
dummy = data1
data1 = data2
data2 = dummy
End If
Else
If data1 > data2 Then
MsgBox "ERRORE: Data1 > Data2!"
DiffDate = "ERRORE DiffDate"
Exit Function
End If
End If
' Calculate total days difference
giorni_totali = Abs(DateDiff("d", data1, data2))
' Calculate years
anni = DateDiff("yyyy", data1, data2)
If DateSerial(Year(data2), Month(data1), Day(data1)) > data2 Then
anni = anni - 1
End If
' Calculate months
tempDate = DateAdd("yyyy", anni, data1)
mesi = DateDiff("m", tempDate, data2)
If DateAdd("m", mesi, tempDate) > data2 Then
mesi = mesi - 1
End If
' Calculate days
giorni = DateDiff("d", DateAdd("m", mesi, DateAdd("yyyy", anni, data1)), data2)
If giorni < 0 Then
mesi = mesi - 1
tempDate = DateAdd("m", mesi, DateAdd("yyyy", anni, data1))
giorni = DateDiff("d", tempDate, data2)
End If
' Adjust for cases where the months calculation might be incorrect
If mesi < 0 Then
mesi = mesi + 12
anni = anni - 1
End If
' Construct output strings
If anni <> 1 Then
anniStr = " anni"
Else
anniStr = " anno"
End If
If mesi <> 1 Then
mesiStr = " mesi"
Else
mesiStr = " mese"
End If
If giorni <> 1 Then
giorniStr = " giorni"
Else
giorniStr = " giorno"
End If
If anni = 0 And mesi = 0 And giorni = giorni_totali Then
giorni_totaliStr = ""
Else
giorni_totaliStr = " (" & CStr(Format(giorni_totali, "#,###")) & " giorni totali)"
End If
' Return requested output
Select Case dato_richiesto
Case "anni"
DiffDate = anni
Case "mesi"
DiffDate = mesi
Case "giorni"
DiffDate = giorni
Case "giorni_totali"
DiffDate = giorni_totali
Case "stringa1"
DiffDate = mesi & mesiStr & ", " & giorni & giorniStr
Case "stringa2"
DiffDate = mesi & mesiStr & ", " & giorni & giorniStr & giorni_totaliStr
Case "nascondi_valori_a_zero"
If anni > 1 Then
anniStr = CStr(anni) & " anni"
If mesi > 1 Or giorni > 1 Then
spaziatura = ", "
End If
ElseIf anni = 1 Then
anniStr = CStr(anni) & " anno"
If mesi >= 1 Or giorni >= 1 Then
spaziatura = ", "
End If
Else
anniStr = ""
spaziatura = ""
End If
anniStr = anniStr & spaziatura
If mesi > 1 Then
mesiStr = CStr(mesi) & " mesi"
If giorni >= 1 Then
spaziatura = ", "
End If
ElseIf mesi = 1 Then
mesiStr = CStr(mesi) & " mese"
If giorni >= 1 Then
spaziatura = ", "
End If
Else
mesiStr = ""
spaziatura = ""
End If
mesiStr = mesiStr & spaziatura
If giorni > 1 Then
giorniStr = CStr(giorni) & " giorni"
ElseIf giorni = 1 Then
giorniStr = CStr(giorni) & " giorno"
Else
giorniStr = ""
End If
DiffDate = TrueTrim(CStr(anniStr & mesiStr & giorniStr & giorni_totaliStr))
If DiffDate = "" Then DiffDate = "nessuna"
Case "stringa3"
DiffDate = anni & anniStr & ", " & mesi & mesiStr & ", " & giorni & giorniStr
Case "stringa4"
DiffDate = anni & anniStr & ", " & mesi & mesiStr & ", " & giorni & giorniStr & giorni_totaliStr
Case "prossimo_compleanno"
DiffDate = data2 & " (" & Giorno_Settimana(data2) & ")"
End Select
Exit Function
ErrorHandler:
MsgBox "Invalid date format. Please enter valid dates."
DiffDate = "ERRORE Invalid Date"
End Function
Upvotes: 3
Views: 378
Reputation: 56016
Your code provides the correct result because "one month" is not a fixed count of days.
I have similar functions:
' Formats the output from AgeMonthsDays.
'
' 2020-10-05. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function FormatAgeYearsMonthsDays( _
ByVal DateOfBirth As Date, _
Optional ByVal AnotherDate As Variant) _
As String
Dim Years As Integer
Dim Months As Integer
Dim Days As Integer
Dim YearsLabel As String
Dim MonthsLabel As String
Dim DaysLabel As String
Dim Result As String
Months = AgeMonthsDays(DateOfBirth, AnotherDate, Days)
Years = Months \ MonthsPerYear
Months = Months Mod MonthsPerYear
YearsLabel = "year" & IIf(Years = 1, "", "s")
MonthsLabel = "month" & IIf(Months = 1, "", "s")
DaysLabel = "day" & IIf(Days = 1, "", "s")
' Concatenate the parts of the output.
Result = CStr(Years) & " " & YearsLabel & ", " & CStr(Months) & " " & MonthsLabel & ", " & CStr(Days) & " " & DaysLabel
FormatAgeYearsMonthsDays = Result
End Function
Output:
Date1 = #30/03/1955#
Date2 = #26/05/2024#
? FormatAgeYearsMonthsDays(Date1, Date2)
69 years, 1 month, 26 days
Date1 = #31/03/1955#
Date2 = #26/05/2024#
? FormatAgeYearsMonthsDays(Date1, Date2)
69 years, 1 month, 26 days
The source function:
' 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
Full code in my repository at GitHub: VBA.Date
Examples
DJ's function may either skip or dupe a day count when the end date moves to the next calendar month.
Here a dupe at day count 16:
Date1 = #2000-04-15#
Date2 = #2002-05-13#
For n = 0 to 33 : ? Date1, n, DateAdd("d", n, Date2), DateDiffToText(Date1, DateAdd("d", n, Date2),1), FormatAgeYearsMonthsDays(Date1, DateAdd("d", n, Date2)) : Next
15-04-2000 0 13-05-2002 2 year(s), 0 month(s), 28 day(s) 2 years, 0 months, 28 days
15-04-2000 1 14-05-2002 2 year(s), 0 month(s), 29 day(s) 2 years, 0 months, 29 days
15-04-2000 2 15-05-2002 2 year(s), 1 month(s), 0 day(s) 2 years, 1 month, 0 days
15-04-2000 3 16-05-2002 2 year(s), 1 month(s), 1 day(s) 2 years, 1 month, 1 day
15-04-2000 4 17-05-2002 2 year(s), 1 month(s), 2 day(s) 2 years, 1 month, 2 days
15-04-2000 5 18-05-2002 2 year(s), 1 month(s), 3 day(s) 2 years, 1 month, 3 days
15-04-2000 6 19-05-2002 2 year(s), 1 month(s), 4 day(s) 2 years, 1 month, 4 days
15-04-2000 7 20-05-2002 2 year(s), 1 month(s), 5 day(s) 2 years, 1 month, 5 days
15-04-2000 8 21-05-2002 2 year(s), 1 month(s), 6 day(s) 2 years, 1 month, 6 days
15-04-2000 9 22-05-2002 2 year(s), 1 month(s), 7 day(s) 2 years, 1 month, 7 days
15-04-2000 10 23-05-2002 2 year(s), 1 month(s), 8 day(s) 2 years, 1 month, 8 days
15-04-2000 11 24-05-2002 2 year(s), 1 month(s), 9 day(s) 2 years, 1 month, 9 days
15-04-2000 12 25-05-2002 2 year(s), 1 month(s), 10 day(s) 2 years, 1 month, 10 days
15-04-2000 13 26-05-2002 2 year(s), 1 month(s), 11 day(s) 2 years, 1 month, 11 days
15-04-2000 14 27-05-2002 2 year(s), 1 month(s), 12 day(s) 2 years, 1 month, 12 days
15-04-2000 15 28-05-2002 2 year(s), 1 month(s), 13 day(s) 2 years, 1 month, 13 days
15-04-2000 16 29-05-2002 2 year(s), 1 month(s), 14 day(s) 2 years, 1 month, 14 days
15-04-2000 17 30-05-2002 2 year(s), 1 month(s), 15 day(s) 2 years, 1 month, 15 days
15-04-2000 18 31-05-2002 2 year(s), 1 month(s), 16 day(s) 2 years, 1 month, 16 days
15-04-2000 19 01-06-2002 2 year(s), 1 month(s), 16 day(s) 2 years, 1 month, 17 days
15-04-2000 20 02-06-2002 2 year(s), 1 month(s), 17 day(s) 2 years, 1 month, 18 days
15-04-2000 21 03-06-2002 2 year(s), 1 month(s), 18 day(s) 2 years, 1 month, 19 days
15-04-2000 22 04-06-2002 2 year(s), 1 month(s), 19 day(s) 2 years, 1 month, 20 days
15-04-2000 23 05-06-2002 2 year(s), 1 month(s), 20 day(s) 2 years, 1 month, 21 days
15-04-2000 24 06-06-2002 2 year(s), 1 month(s), 21 day(s) 2 years, 1 month, 22 days
15-04-2000 25 07-06-2002 2 year(s), 1 month(s), 22 day(s) 2 years, 1 month, 23 days
15-04-2000 26 08-06-2002 2 year(s), 1 month(s), 23 day(s) 2 years, 1 month, 24 days
15-04-2000 27 09-06-2002 2 year(s), 1 month(s), 24 day(s) 2 years, 1 month, 25 days
15-04-2000 28 10-06-2002 2 year(s), 1 month(s), 25 day(s) 2 years, 1 month, 26 days
15-04-2000 29 11-06-2002 2 year(s), 1 month(s), 26 day(s) 2 years, 1 month, 27 days
15-04-2000 30 12-06-2002 2 year(s), 1 month(s), 27 day(s) 2 years, 1 month, 28 days
15-04-2000 31 13-06-2002 2 year(s), 1 month(s), 28 day(s) 2 years, 1 month, 29 days
15-04-2000 32 14-06-2002 2 year(s), 1 month(s), 29 day(s) 2 years, 1 month, 30 days
15-04-2000 33 15-06-2002 2 year(s), 2 month(s), 0 day(s) 2 years, 2 months, 0 days
Here a skip at day count 16:
Date1 = #2000-03-15#
Date2 = #2002-04-13#
For n = 0 to 33 : ? Date1, n, DateAdd("d", n, Date2), DateDiffToText(Date1, DateAdd("d", n, Date2),1), FormatAgeYearsMonthsDays(Date1, DateAdd("d", n, Date2)) : Next
15-03-2000 0 13-04-2002 2 year(s), 0 month(s), 29 day(s) 2 years, 0 months, 29 days
15-03-2000 1 14-04-2002 2 year(s), 0 month(s), 30 day(s) 2 years, 0 months, 30 days
15-03-2000 2 15-04-2002 2 year(s), 1 month(s), 0 day(s) 2 years, 1 month, 0 days
15-03-2000 3 16-04-2002 2 year(s), 1 month(s), 1 day(s) 2 years, 1 month, 1 day
15-03-2000 4 17-04-2002 2 year(s), 1 month(s), 2 day(s) 2 years, 1 month, 2 days
15-03-2000 5 18-04-2002 2 year(s), 1 month(s), 3 day(s) 2 years, 1 month, 3 days
15-03-2000 6 19-04-2002 2 year(s), 1 month(s), 4 day(s) 2 years, 1 month, 4 days
15-03-2000 7 20-04-2002 2 year(s), 1 month(s), 5 day(s) 2 years, 1 month, 5 days
15-03-2000 8 21-04-2002 2 year(s), 1 month(s), 6 day(s) 2 years, 1 month, 6 days
15-03-2000 9 22-04-2002 2 year(s), 1 month(s), 7 day(s) 2 years, 1 month, 7 days
15-03-2000 10 23-04-2002 2 year(s), 1 month(s), 8 day(s) 2 years, 1 month, 8 days
15-03-2000 11 24-04-2002 2 year(s), 1 month(s), 9 day(s) 2 years, 1 month, 9 days
15-03-2000 12 25-04-2002 2 year(s), 1 month(s), 10 day(s) 2 years, 1 month, 10 days
15-03-2000 13 26-04-2002 2 year(s), 1 month(s), 11 day(s) 2 years, 1 month, 11 days
15-03-2000 14 27-04-2002 2 year(s), 1 month(s), 12 day(s) 2 years, 1 month, 12 days
15-03-2000 15 28-04-2002 2 year(s), 1 month(s), 13 day(s) 2 years, 1 month, 13 days
15-03-2000 16 29-04-2002 2 year(s), 1 month(s), 14 day(s) 2 years, 1 month, 14 days
15-03-2000 17 30-04-2002 2 year(s), 1 month(s), 15 day(s) 2 years, 1 month, 15 days
15-03-2000 18 01-05-2002 2 year(s), 1 month(s), 17 day(s) 2 years, 1 month, 16 days
15-03-2000 19 02-05-2002 2 year(s), 1 month(s), 18 day(s) 2 years, 1 month, 17 days
15-03-2000 20 03-05-2002 2 year(s), 1 month(s), 19 day(s) 2 years, 1 month, 18 days
15-03-2000 21 04-05-2002 2 year(s), 1 month(s), 20 day(s) 2 years, 1 month, 19 days
15-03-2000 22 05-05-2002 2 year(s), 1 month(s), 21 day(s) 2 years, 1 month, 20 days
15-03-2000 23 06-05-2002 2 year(s), 1 month(s), 22 day(s) 2 years, 1 month, 21 days
15-03-2000 24 07-05-2002 2 year(s), 1 month(s), 23 day(s) 2 years, 1 month, 22 days
15-03-2000 25 08-05-2002 2 year(s), 1 month(s), 24 day(s) 2 years, 1 month, 23 days
15-03-2000 26 09-05-2002 2 year(s), 1 month(s), 25 day(s) 2 years, 1 month, 24 days
15-03-2000 27 10-05-2002 2 year(s), 1 month(s), 26 day(s) 2 years, 1 month, 25 days
15-03-2000 28 11-05-2002 2 year(s), 1 month(s), 27 day(s) 2 years, 1 month, 26 days
15-03-2000 29 12-05-2002 2 year(s), 1 month(s), 28 day(s) 2 years, 1 month, 27 days
15-03-2000 30 13-05-2002 2 year(s), 1 month(s), 29 day(s) 2 years, 1 month, 28 days
15-03-2000 31 14-05-2002 2 year(s), 1 month(s), 30 day(s) 2 years, 1 month, 29 days
15-03-2000 32 15-05-2002 2 year(s), 2 month(s), 0 day(s) 2 years, 2 months, 0 days
15-03-2000 33 16-05-2002 2 year(s), 2 month(s), 1 day(s) 2 years, 2 months, 1 day
Upvotes: 0
Reputation: 16257
Adding my own code because other answers are incorrect and want you to believe that duplicates and gaps in results are perfectly acceptable.
Updated: added CountDateOnLastDayAsFullMonth
boolean flag to treat end dates that fall on the last day of the month to count as full months (this will create dup results for some date ranges)
Public Function DateDiffToText(ByVal StartDate As Date, ByVal EndDate As Date, Optional ByVal CountDateOnLastDayAsFullMonth As Boolean = False)
' expresses a date range difference in years, months and days
' useful for countdown timers or age calcs
'
' Set CountDateOnLastDayAsFullMonth = true if you want end dates that fall on the last day of the month to count as full months
' - this will create dup results for some date ranges
'
' year calc - counts any complete calendar years between dates + one year if start day/month is < end day/month
' Month calc - similiar to year calc - counts complete months (regardless of days) between dates
' on the remainder after subtracting complete years + one month if start day of month (DOM) < end DOM
'
' Day calc - based on the DOM - if start DOM <= end DOM then just the days remaining from start to end DOM,
' else we calc days remaining in start month and add days in end month
'
' By: @DJ. - David Johnston - Burnaby, Canada
Dim Years As Integer
Dim Months As Integer
Dim Days As Integer
Dim StartYear As Integer
Dim StartMonth As Integer
Dim StartDay As Integer
Dim StartMonthDay As Integer
Dim EndYear As Integer
Dim EndMonth As Integer
Dim EndDay As Integer
Dim EndMonthDay As Integer
Dim TempMonth As Integer
Dim TempDate As Date
Dim TempDate2 As Date
' split up date parts
StartYear = Year(StartDate)
StartMonth = Month(StartDate)
StartDay = Day(StartDate)
StartMonthDay = (StartMonth * 100) + StartDay
EndYear = Year(EndDate)
EndMonth = Month(EndDate)
EndDay = Day(EndDate)
EndMonthDay = (EndMonth * 100) + EndDay
'Calculate Years
Years = EndYear - StartYear - 1
If EndMonthDay >= StartMonthDay Then Years = Years + 1
'Calculate Months
TempMonth = EndMonth
If EndMonthDay < StartMonthDay Then TempMonth = TempMonth + 12
Months = TempMonth - StartMonth - 1
If EndDay >= StartDay Then Months = Months + 1
' Calculate Days
If StartDay <= EndDay Then
Days = EndDay - StartDay
Else
'get number of days remaing in month by getting last date of the month
TempDate = DateAdd("m", 1, StartDate)
TempDate = DateSerial(Year(TempDate), Month(TempDate), 1)
TempDate = DateAdd("d", -1, TempDate)
If CountDateOnLastDayAsFullMonth = True Then
TempDate2 = DateAdd("m", 1, EndDate)
TempDate2 = DateSerial(Year(TempDate2), Month(TempDate2), 1)
TempDate2 = DateAdd("d", -1, TempDate2)
If EndDate = TempDate2 Then
'special case - end date is last day of month - count it as a full month
Days = Day(TempDate) - StartDay
Months = Months + 1
If Months = 12 Then
Months = 0
Years = Years + 1
End If
Else
Days = Day(TempDate) - StartDay + EndDay
End If
Else
Days = Day(TempDate) - StartDay + EndDay
End If
End If
DateDiffToText = CStr(Years) & " year(s), " & CStr(Months) & " month(s), " & CStr(Days) & " day(s)"
End Function
Results:
Updated: Results with CountDateOnLastDayAsFullMonth = True
Upvotes: 0
Reputation: 60464
It seems you want to calculate using Calendar Months
. You may try this code:
Note that there are optional arguments for output to include weeks
or fraction of a month
.
Option Explicit
Function CalendarMonths(d1 As Date, d2 As Date, _
Optional Weeks As Boolean = False, Optional FracMonth As Boolean = False)
'FracMonth --> output as Month+fraction of months based on
' days in the starting and ending month
'Without FracMonth, output is in years, full calendar months, and days
Dim temp As Date
Dim I As Double
Dim YR As Long, mnth As Long, DY As Long
Dim wk As Long
Dim FirstFrac As Double, LastFrac As Double
Dim Yrstr As String, Mnstr As String, Dystr As String
Dim Wkstr As String
Dim NegFlag As Boolean
Dim sOutput() As String
If FracMonth = True Then Weeks = False
NegFlag = False
If d1 > d2 Then
NegFlag = True
temp = d1
d1 = d2
d2 = temp
End If
temp = 0
Do Until temp >= d2
I = I + 1
temp = EOM(d1, I)
Loop
If temp <> d2 Then I = I - 1
If FracMonth = True Then
FirstFrac = (EOM(d1, 0) - d1) / Day(EOM(d1, 0))
LastFrac = (d2 - EOM(d2, -1)) / Day(EOM(d2, 0))
LastFrac = LastFrac - Int(LastFrac)
CalendarMonths = I + FirstFrac + LastFrac
If NegFlag = True Then CalendarMonths = -CalendarMonths
Else
YR = Int(I / 12)
mnth = I Mod 12
DY = d2 - EOM(d1, I) + (EOM(d1, 0) - d1)
If Weeks = True Then
wk = Int(DY / 7)
DY = DY Mod 7
End If
ReDim sOutput(0 To -(YR > 0) - (mnth > 0) - (wk > 0) - (DY > 0) - 1)
I = 0
If YR > 0 Then
sOutput(I) = YR & IIf(YR = 1, " Year", " Years")
I = I + 1
End If
If mnth > 0 Then
sOutput(I) = mnth & IIf(mnth = 1, " Month", " Months")
I = I + 1
End If
If wk > 0 Then
sOutput(I) = wk & IIf(wk = 1, " Week", " Weeks")
I = I + 1
End If
If DY > 0 Then sOutput(I) = DY & IIf(DY = 1, " Day", " Days")
CalendarMonths = Join(sOutput, ", ")
If NegFlag Then CalendarMonths = "(Neg) " & CalendarMonths
End If
End Function
Note that for jurisdictions where a leapling's birthday is considered to be Mar 1 vs Feb 28 during non-leap years, this formula will return an incorrect age on those dates
Upvotes: 0
Reputation: 16257
Your code in this section is incorrect:
' Calculate days
giorni = DateDiff("d", DateAdd("m", mesi, DateAdd("yyyy", anni, data1)), data2)
If giorni < 0 Then
mesi = mesi - 1
tempDate = DateAdd("m", mesi, DateAdd("yyyy", anni, data1))
giorni = DateDiff("d", tempDate, data2)
End If
You need to find the number of days remaining in the month of the first date and use that to add to the days in second date. Like this:
' Calculate days
Dim d1 As Integer, d2 As Integer
d1 = Day(data1)
d2 = Day(data2)
If d1 <= d2 Then
giorni = d2 - d1
Else
'get number of days in month by setting tempdate to last date of the month
tempDate = DateAdd("m", 1, data1)
tempDate = DateSerial(Year(tempDate), Month(tempDate), 1)
tempDate = DateAdd("d", -1, tempDate)
giorni = Day(tempDate) - d1 + d2
End If
You then get the expected output
03/30/1955 - 69 anni, 1 mese, 27 giorni (25,260 giorni totali)
03/31/1955 - 69 anni, 1 mese, 26 giorni (25,259 giorni totali)
Upvotes: 0