vb6 Date Difference Calculations

Hi Guys

The following function returns a string representing the date difference between two dates:

Public Function DateDiffEx(StartDate As Variant, FinishDate As Variant) As String

    Dim yer As Integer, mon As Integer, d As Integer
    Dim dt As Date
    Dim fd As Date
    
    Dim sAns  As String

    dt = CDate(StartDate)       ' our start date
    fd = CDate(FinishDate)      ' our finish date
    
    yer = Year(dt)              ' year of our start date
    mon = Month(dt)             ' month of ..
    d = Day(dt)                 ' day of ...
    
    yer = Year(fd) - yer        ' year of our finish date
    mon = Month(fd) - mon       ' month of ..
    d = Day(fd) - d             ' day of ...

    If Sgn(d) = -1 Then         ' are we less than 0
        d = 30 - Abs(d)
        mon = mon - 1
    End If

    If Sgn(mon) = -1 Then
        mon = 12 - Abs(mon)
        yer = yer - 1
    End If
    
    Dim wek As Integer          ' work our how many weeks
     If d > 7 Then              ' if the number of days is larger than 7 - theres a week or more in it
        wek = d / 7             ' wek = days / 7
        d = d Mod 7             ' d = gets the mod (remiander) after taking out whole weeks
        wek = wek - 1           ' take 1 away
     End If
    
    ' build our answer
    If yer > 0 Then
        sAns = yer & " year" & IIf(yer > 1, "(s), ", ", ")
    End If
    
    If mon > 0 Then
       sAns = sAns & mon & " month" & IIf(mon > 1, "(s), ", ", ")
    End If
    
    If wek > 0 Then
       sAns = sAns & wek & " Week" & IIf(wek > 1, "(s), ", ", ")
    End If
    
    If d > 0 Then
       sAns = sAns & d & " Day" & IIf(d > 1, "(s)", "")
    End If
    
    'sAns = yer & " year(s) " & mon & " month(s) " & wek & " Week(s), " & d & " day(s)"

    DateDiffEx = sAns

End Function

Open in new window


It works for dates where there is more than 1 months difference.

For example,

msgbox DateDiffEx(CDate("06 Aug 1965"), CDate(now))

returns 49 years, 2 months, 1 week, 5 days

However, the following returns 1 day which is a week out of kilter

msgbox DateDiffEx(CDate("18 Oct 2014"), CDate("26 Oct 2014"))

returns 1 day

I know the problem exists because I subtract 1 from wek

     If d > 7 Then              ' if the number of days is larger than 7 - theres a week or more in it
        wek = d / 7             ' wek = days / 7
        d = d Mod 7             ' d = gets the mod (remiander) after taking out whole weeks
        wek = wek - 1           ' take 1 away
     End If

Open in new window


but dont know how to resolve the issue ...

MTIA

DWE
LVL 1
dwe0608Asked:
Who is Participating?
 
Martin LissConnect With a Mentor Older than dirtCommented:
This function is from the web.
'Usage:
MsgBox YearsMonthsDays(CDate("06 Aug 1965"), Now, True)

Open in new window


Function YearsMonthsDays(Date1 As Date, Date2 As Date, Optional ShowAll As _
    Boolean = False, Optional Grammar As Boolean = True)
     
     ' This function returns a string "X years, Y months, Z days" showing the time
     ' between two dates.  This function may be used in any VBA or VB project
     
     ' Date1 and Date2 must either be dates, or strings that can be implicitly
     ' converted to dates.  If these arguments have time portions, the time portions
     ' are ignored. If Date1 > Date2 (after ignoring time portions), the function
     ' returns an empty string
     
     ' ShowAll indicates whether all portions of the string "X years, Y months, Z days"
     ' are included in the output.  If ShowAll = True, all portions of the string are
     ' always included.  If ShowAll = False, then if the year portion is zero the year
     ' part of the string is omitted, and if the year portion and month portion are both
     ' zero, than both year and month portions are omitted.  The day portion is always
     ' included, and if at least one year has passed then the month portion is always
     ' included
     
     ' Grammar indicates whether to test years/months/days for singular or plural
     
     ' By definition, a "full month" means that the day number in Date2 is >= the day
     ' number in Date1, or Date1 and Date2 occur on the last days of their respective
     ' months. A "full year" means that 12 "full months" have passed.
    
     
    Dim TestYear As Long, TestMonth As Long, TestDay As Long
    Dim TargetDate As Date, Last1 As Date, Last2 As Date
     
     ' Strip time portions
    Date1 = Int(Date1)
    Date2 = Int(Date2)
     
     ' Test for invalid dates
    If Date1 > Date2 Then
        YearsMonthsDays = ""
        Exit Function
    End If
     
     ' Test for whether the calendar year is the same
    If Year(Date2) > Year(Date1) Then
         
         ' Different calendar year.
         
         ' Test to see if calendar month is the same.  If it is, we have to look at the
         ' day to see if a full year has passed
        If Month(Date2) = Month(Date1) Then
            If Day(Date2) >= Day(Date1) Then
                TestYear = DateDiff("yyyy", Date1, Date2)
            Else
                TestYear = DateDiff("yyyy", Date1, Date2) - 1
            End If
             
             ' In this case, a full year has definitely passed
        ElseIf Month(Date2) > Month(Date1) Then
            TestYear = DateDiff("yyyy", Date1, Date2)
             
             ' A full year has not passed
        Else
            TestYear = DateDiff("yyyy", Date1, Date2) - 1
        End If
         
         ' Calendar year is the same, so a full year has not passed
    Else
        TestYear = 0
    End If
     
     ' Test to see how many full months have passed, in excess of the number of full
     ' years
    TestMonth = (DateDiff("m", DateSerial(Year(Date1), Month(Date1), 1), _
    DateSerial(Year(Date2), Month(Date2), 1)) + IIf(Day(Date2) >= _
    Day(Date1), 0, -1)) Mod 12
     
     ' See how many days have passed, in excess of the number of full months.  If the day
     ' number for Date2 is >= that for Date1, it's simple
    If Day(Date2) >= Day(Date1) Then
        TestDay = Day(Date2) - Day(Date1)
         
         ' If not, we have to test for end of the month
    Else
        Last1 = DateSerial(Year(Date2), Month(Date2), 0)
        Last2 = DateSerial(Year(Date2), Month(Date2) + 1, 0)
        TargetDate = DateSerial(Year(Date2), Month(Date2) - 1, Day(Date1))
        If Last2 = Date2 Then
            If TestMonth = 11 Then
                TestMonth = 0
                TestYear = TestYear + 1
            Else
                TestMonth = TestMonth + 1
            End If
        Else
            TestDay = DateDiff("d", IIf(TargetDate > Last1, Last1, TargetDate), Date2)
        End If
    End If
     
    If ShowAll Or TestYear >= 1 Then
        YearsMonthsDays = TestYear & IIf(TestYear = 1 And Grammar, " year, ", _
        " years, ") & TestMonth & IIf(TestMonth = 1 And Grammar, " month, ", _
        " months, ") & TestDay & IIf(TestDay = 1 And Grammar, " day", " days")
    Else
        If TestMonth >= 1 Then
            YearsMonthsDays = TestMonth & IIf(TestMonth = 1 And Grammar, " month, ", _
            " months, ") & TestDay & IIf(TestDay = 1 And Grammar, " day", " days")
        Else
            YearsMonthsDays = TestDay & IIf(TestDay = 1 And Grammar, " day", " days")
        End If
    End If
     
End Function

Open in new window

0
 
Martin LissOlder than dirtCommented:
Why not use the built-in DateDiff Function?
0
 
dwe0608Author Commented:
Hi Martin,

I found it inaccurate - I started off using it and ran into problems ... if you could show me how datediff would be used to return the same sort of string I'd be interested ...
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
Martin LissOlder than dirtCommented:
MsgBox DateDiff("d", CDate("18 Oct 2014"), CDate("26 Oct 2014"))

Returns 8
0
 
Martin LissOlder than dirtCommented:
BTW the above returns Years, Months, Days, so you get in the above example

49 years, 2 months, 11 days

which is one day different from your result but it seems to be correct because if you add two months to Aug 6 you get Oct 6 and there are 11 days between then and now (Oct 17).

BTW the function could easily be changed so that instead of 11 days it would show 1 week 4 days.
0
 
dwe0608Author Commented:
Hi Martin, you've got the idea - the function I use does the same thing but doesn't have weeks in it ...

YearsMonthsDays(CDate("06 Aug 1965"), Now, True)

returns 49 years, 2 months, 12 days

its the number of weeks I am looking to include ... and I am having difficulty with ... using the example you gave, 12 days should convert to 1 week and 5 days - thats where my difficulty lay ...
0
 
dwe0608Author Commented:
BTW - I am in Australian time, and you're on USA time, so the date difference of a day is explainable :-)
0
 
Martin LissOlder than dirtCommented:
YearsMonthsDays(CDate("06 Aug 1965"), Now, True)

returns 49 years, 2 months, 12 days
Is it still Oct 17th where you are, because here in the USA where it is the 17th I get 49 years, 2 months, 11 days
0
 
dwe0608Author Commented:
;-) ... no its 18 October here ...
0
 
Martin LissOlder than dirtCommented:
OK, if using different dates "my" function gave for example 49 years, 2 months, 5 days, do you want the result to be

49 years, 2 months, 5 days

or

49 years, 2 months, 0 weeks, 5 days
0
 
dwe0608Author Commented:
if you use your function and use the start date as 1 August 1965 - I would want the result to say 49 years, 2 months, 2 weeks, 3 days
0
 
Martin LissOlder than dirtCommented:
Here's a start. Add these lines at the bottom of the function. The "weeks"/"week" and "Days"/"Day" isn't handled but I assume you can fix that.

    'new
    Dim intPos As Integer
    Dim strTemp As String
    intPos = InStrRev(YearsMonthsDays, ",")
    strTemp = Mid(YearsMonthsDays, intPos + 2)
    If Val(strTemp) > 7 Then
        strTemp = Val(strTemp) \ 7 & " weeks, " & Val(strTemp) Mod 7 & " days"
    End If
    YearsMonthsDays = Left$(YearsMonthsDays, intPos) & strTemp

Open in new window

0
 
dwe0608Author Commented:
Martin, using the following function - do you get the correct result ?



Public Function DateDiffEx(StartDate As Variant, FinishDate As Variant) As String

    Dim yer As Integer, mon As Integer, d As Integer
    Dim dt As Date
    Dim fd As Date
    
    Dim sAns  As String

    dt = CDate(StartDate)       ' our start date
    fd = CDate(FinishDate)      ' our finish date
    
    yer = Year(dt)              ' year of our start date
    mon = Month(dt)             ' month of ..
    d = Day(dt)                 ' day of ...
    
    yer = Year(fd) - yer        ' year of our finish date
    mon = Month(fd) - mon       ' month of ..
    d = Day(fd) - d             ' day of ...

    If Sgn(d) = -1 Then         ' are we less than 0
        d = 30 - Abs(d)
        mon = mon - 1
    End If

    If Sgn(mon) = -1 Then
        mon = 12 - Abs(mon)
        yer = yer - 1
    End If
    
    Dim wek As Integer          ' work our how many weeks
     If d > 7 Then              ' if the number of days is larger than 7 - theres a week or more in it
     Debug.Print "days = " & d
        wek = d / 7             ' wek = days / 7
        d = (d + 1) Mod 7           ' d = gets the mod (remiander) after taking out whole weeks
        wek = IIf(mon > 0, wek - 1, wek)         ' take 1 away
     End If
    
    ' build our answer
    If yer > 0 Then
        sAns = yer & " year" & IIf(yer > 1, "(s), ", ", ")
    End If
    
    If mon > 0 Then
       sAns = sAns & mon & " month" & IIf(mon > 1, "(s), ", ", ")
    End If
    
    If wek > 0 Then
       sAns = sAns & wek & " Week" & IIf(wek > 1, "(s), ", ", ")
    End If
    
    If d > 0 Then
       sAns = sAns & d & " Day" & IIf(d > 1, "(s)", "")
    End If
    
    'sAns = yer & " year(s) " & mon & " month(s) " & wek & " Week(s), " & d & " day(s)"

    DateDiffEx = sAns

End Function

Open in new window

0
 
Martin LissOlder than dirtCommented:
I get

49 year(s), 2 month(s), 1 Week, 5 Day(s)
0
 
dwe0608Author Commented:
where StartDate = 06 Aug 1965 and FinishDate = 17 Oct 2014 ?
if so its returning the correct result ...

but the value of wek is not consistantly correct? When using smaller date differences ... such as about 3 weeks ...

Can you see why ?
0
 
Martin LissOlder than dirtCommented:
I haven't looked at it in detail but I just did a test and while

YearsMonthsDays(CDate("31-Jan-2006"), CDate("1-Mar-2006"), True) -> 0 years, 1 month, 1 day
DateDiffEx(CDate("31-Jan-2006"), CDate("1-Mar-2006")) -> 1 month,

so it would seem that your function has some problems,
0
 
dwe0608Author Commented:
yes I recognised that at the outset ... thats why I posted a query and sought some assistance ..
0
 
Martin LissOlder than dirtCommented:
Why not use YearsMonthsDays (modified to suit your output requirements) instead of DateDiffEx?
0
 
dwe0608Author Commented:
Can you tell me - why is wek = 2 when it should be equal to 1. ie 13/7 is returning 2

where TestDay = 13 ...

     Dim wek As Integer             ' work our how many weeks
     If TestDay >= 7 Then             ' if the number of days is larger than or equal to 7 - theres a week or more in it
        Debug.Print "TestDay = " & TestDay
        wek = TestDay / 7
        Debug.Print "Wek = " & wek
        TestDay = TestDay Mod 7             ' d = gets the mod (remiander) after taking out whole weeks
        Debug.Print "TestDay = " & TestDay
     End If

Open in new window

0
 
Martin LissOlder than dirtCommented:
Because TestDay / 7 yields 1.85714285714286 which is automatically rounded by VB to 2. If you do TestDay \ 7 (which is integer division) it will yield 1.
0
 
dwe0608Author Commented:
thanks - I picked up that a moment after I posted it ... must be tired ...

heres the function you posted modded to include weeks ...

Function YearsMonthsDays(Date1 As Date, Date2 As Date, Optional ShowAll As _
    Boolean = False, Optional Grammar As Boolean = True)
     
     ' This function returns a string "X years, Y months, Z days" showing the time
     ' between two dates.  This function may be used in any VBA or VB project
     
     ' Date1 and Date2 must either be dates, or strings that can be implicitly
     ' converted to dates.  If these arguments have time portions, the time portions
     ' are ignored. If Date1 > Date2 (after ignoring time portions), the function
     ' returns an empty string
     
     ' ShowAll indicates whether all portions of the string "X years, Y months, Z days"
     ' are included in the output.  If ShowAll = True, all portions of the string are
     ' always included.  If ShowAll = False, then if the year portion is zero the year
     ' part of the string is omitted, and if the year portion and month portion are both
     ' zero, than both year and month portions are omitted.  The day portion is always
     ' included, and if at least one year has passed then the month portion is always
     ' included
     
     ' Grammar indicates whether to test years/months/days for singular or plural
     
     ' By definition, a "full month" means that the day number in Date2 is >= the day
     ' number in Date1, or Date1 and Date2 occur on the last days of their respective
     ' months. A "full year" means that 12 "full months" have passed.
    
     
    Dim TestYear As Long, TestMonth As Long, TestDay As Long
    Dim TargetDate As Date, Last1 As Date, Last2 As Date
     
     ' Strip time portions
    Date1 = Int(Date1)
    Date2 = Int(Date2)
     
     ' Test for invalid dates
    If Date1 > Date2 Then
        YearsMonthsDays = ""
        Exit Function
    End If
     
     ' Test for whether the calendar year is the same
    If Year(Date2) > Year(Date1) Then
         
         ' Different calendar year.
         
         ' Test to see if calendar month is the same.  If it is, we have to look at the
         ' day to see if a full year has passed
        If Month(Date2) = Month(Date1) Then
            If Day(Date2) >= Day(Date1) Then
                TestYear = DateDiff("yyyy", Date1, Date2)
            Else
                TestYear = DateDiff("yyyy", Date1, Date2) - 1
            End If
             
             ' In this case, a full year has definitely passed
        ElseIf Month(Date2) > Month(Date1) Then
            TestYear = DateDiff("yyyy", Date1, Date2)
             
             ' A full year has not passed
        Else
            TestYear = DateDiff("yyyy", Date1, Date2) - 1
        End If
         
         ' Calendar year is the same, so a full year has not passed
    Else
        TestYear = 0
    End If
     
     ' Test to see how many full months have passed, in excess of the number of full
     ' years
    TestMonth = (DateDiff("m", DateSerial(Year(Date1), Month(Date1), 1), _
    DateSerial(Year(Date2), Month(Date2), 1)) + IIf(Day(Date2) >= _
    Day(Date1), 0, -1)) Mod 12
     
     ' See how many days have passed, in excess of the number of full months.  If the day
     ' number for Date2 is >= that for Date1, it's simple
    If Day(Date2) >= Day(Date1) Then
        TestDay = Day(Date2) - Day(Date1)
         
         ' If not, we have to test for end of the month
    Else
        Last1 = DateSerial(Year(Date2), Month(Date2), 0)
        Last2 = DateSerial(Year(Date2), Month(Date2) + 1, 0)
        TargetDate = DateSerial(Year(Date2), Month(Date2) - 1, Day(Date1))
        If Last2 = Date2 Then
            If TestMonth = 11 Then
                TestMonth = 0
                TestYear = TestYear + 1
            Else
                TestMonth = TestMonth + 1
            End If
        Else
            TestDay = DateDiff("d", IIf(TargetDate > Last1, Last1, TargetDate), Date2)
        End If
    End If
     
     
    ' ok work out if there is a weeks calculation to be slotted in
     Dim wek As Integer             ' work our how many weeks
     If TestDay >= 7 Then             ' if the number of days is larger than or equal to 7 - theres a week or more in it
        wek = TestDay \ 7
        TestDay = TestDay Mod 7             ' d = gets the mod (remiander) after taking out whole weeks
     End If
     
    
    If ShowAll Or TestYear >= 1 Then
        YearsMonthsDays = TestYear & IIf(TestYear = 1 And Grammar, " year, ", " years, ") & _
                          TestMonth & IIf(TestMonth = 1 And Grammar, " month, ", " months, ") & _
                          wek & IIf(wek = 1 And Grammar, " week, ", " weeks, ") & _
                          TestDay & IIf(TestDay = 1 And Grammar, " day", " days")
    Else
        If TestMonth >= 1 Then
            YearsMonthsDays = TestMonth & IIf(TestMonth = 1 And Grammar, " month, ", " months, ") & _
                              TestDay & IIf(TestDay = 1 And Grammar, " day", " days")
        Else
            YearsMonthsDays = TestDay & IIf(TestDay = 1 And Grammar, " day", " days")
        End If
    End If
     
     
End Function

Open in new window


Thanks for the patient assistance ...
0
 
Martin LissOlder than dirtCommented:
You're welcome and I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2014
0
All Courses

From novice to tech pro — start learning today.