VB Forum / General 2 / December 2004

Months are a tricky thing when used as part of a Year/Month/Day time
period... it has to be calculated individually. Here is a past posting
of mine that provided a function (actually, two functions) that you can
probably make use of. Note that they both include the time as well as
date in their output, so you might want to modify them for your own use.

Rick - MVP

I had a function which
calculates time elapsed given two dates; so I modified it for you. This
first version gives you time elapsed with "WEEKS" as one of the
sub-intervals; the second one without the "WEEKS" sub-interval. (Note
the function name differences.) Hopefully one of these is what you were
looking for.

Version #1 (With "WEEKS")
==========================
Function YMWDHMS(ByVal SecondsIn As Variant) As String
 Dim TempDate As Date
 Dim NumOfYears As Long
 Dim NumOfMonths As Long
 Dim NumOfWeeks As Long
 Dim NumOfDays As Long
 Dim NumOfHMS As Double
 Dim TSerial1 As Double
 Dim TSerial2 As Double
   Date2 = Now
   Date1 = DateAdd("s", -SecondsIn, Date2)
   NumOfYears = DateDiff("yyyy", Date1, Date2)
   TSerial1 = TimeSerial(Hour(Date1), Minute(Date1), Second(Date1))
   TSerial2 = TimeSerial(Hour(Date2), Minute(Date2), Second(Date2))
   NumOfHMS = 24 * (TSerial2 - TSerial1)
   If NumOfHMS < 0 Then
     NumOfHMS = NumOfHMS + 24
     Date2 = DateAdd("d", -1, Date2)
   End If
   Date1 = DateSerial(Year(Date2), Month(Date1), Day(Date1))
   If Date1 > Date2 Then
      Date1 = DateAdd("yyyy", -1, Date1)
      NumOfYears = NumOfYears - 1
   End If
   NumOfMonths = DateDiff("m", Date1, Date2)
   Date1 = DateSerial(Year(Date2), Month(Date2), Day(Date1))
   If Date1 > Date2 Then
      Date1 = DateAdd("m", -1, Date1)
      NumOfMonths = NumOfMonths - 1
   End If
   NumOfDays = Abs(DateDiff("d", Date1, Date2))
   NumOfWeeks = NumOfDays \ 7
   NumOfDays = NumOfDays Mod 7
   ' Format the Years, Months, Weeks, Days part
   YMWDHMS = CStr(NumOfYears) & " year" & _
             IIf(NumOfYears = 1, "", "s")
   YMWDHMS = YMWDHMS & ", "
   YMWDHMS = YMWDHMS & CStr(NumOfMonths) & _
                            " month" & IIf(NumOfMonths = 1, "", "s")
   YMWDHMS = YMWDHMS & ", "
   YMWDHMS = YMWDHMS & CStr(NumOfWeeks) & _
                            " week" & IIf(NumOfWeeks = 1, "", "s")
   YMWDHMS = YMWDHMS & ", "
   YMWDHMS = YMWDHMS & CStr(NumOfDays) & _
                            " day" & IIf(NumOfDays = 1, "", "s")
   ' Format the Hours, Minutes and Seconds part
   YMWDHMS = YMWDHMS & ", "
   YMWDHMS = YMWDHMS & CStr(Int(NumOfHMS)) & _
                            " hour" & IIf(Int(NumOfHMS) = 1, "", "s")
   NumOfHMS = 60 * (NumOfHMS - Int(NumOfHMS))
   YMWDHMS = YMWDHMS & ", "
   YMWDHMS = YMWDHMS & CStr(Int(NumOfHMS)) & _
                            " minute" & IIf(Int(NumOfHMS) = 1, "", "s")
   NumOfHMS = 60 * (NumOfHMS - Int(NumOfHMS))
   YMWDHMS = YMWDHMS & ", "
   YMWDHMS = YMWDHMS & CStr(CInt(NumOfHMS)) & _
                            " second" & IIf(Int(NumOfHMS) = 1, "", "s")
End Function

Version #2 (Without "WEEKS")
=============================
Function YMDHMS(ByVal SecondsIn As Variant) As String
 Dim TempDate As Date
 Dim NumOfYears As Long
 Dim NumOfMonths As Long
 Dim NumOfWeeks As Long
 Dim NumOfDays As Long
 Dim NumOfHMS As Double
 Dim TSerial1 As Double
 Dim TSerial2 As Double
   Date2 = Now
   Date1 = DateAdd("s", -SecondsIn, Date2)
   NumOfYears = DateDiff("yyyy", Date1, Date2)
   TSerial1 = TimeSerial(Hour(Date1), Minute(Date1), Second(Date1))
   TSerial2 = TimeSerial(Hour(Date2), Minute(Date2), Second(Date2))
   NumOfHMS = 24 * (TSerial2 - TSerial1)
   If NumOfHMS < 0 Then
     NumOfHMS = NumOfHMS + 24
     Date2 = DateAdd("d", -1, Date2)
   End If
   Date1 = DateSerial(Year(Date2), Month(Date1), Day(Date1))
   If Date1 > Date2 Then
      Date1 = DateAdd("yyyy", -1, Date1)
      NumOfYears = NumOfYears - 1
   End If
   NumOfMonths = DateDiff("m", Date1, Date2)
   Date1 = DateSerial(Year(Date2), Month(Date2), Day(Date1))
   If Date1 > Date2 Then
      Date1 = DateAdd("m", -1, Date1)
      NumOfMonths = NumOfMonths - 1
   End If
   NumOfDays = Abs(DateDiff("d", Date1, Date2))
   ' Format the Years, Months, Weeks, Days part
   YMDHMS = CStr(NumOfYears) & " year" & _
             IIf(NumOfYears = 1, "", "s")
   YMDHMS = YMDHMS & ", "
   YMDHMS = YMDHMS & CStr(NumOfMonths) & _
                            " month" & IIf(NumOfMonths = 1, "", "s")
   YMDHMS = YMDHMS & ", "
   YMDHMS = YMDHMS & CStr(NumOfDays) & _
                            " day" & IIf(NumOfDays = 1, "", "s")
   ' Format the Hours, Minutes and Seconds part
   YMDHMS = YMDHMS & ", "
   YMDHMS = YMDHMS & CStr(Int(NumOfHMS)) & _
                            " hour" & IIf(Int(NumOfHMS) = 1, "", "s")
   NumOfHMS = 60 * (NumOfHMS - Int(NumOfHMS))
   YMDHMS = YMDHMS & ", "
   YMDHMS = YMDHMS & CStr(Int(NumOfHMS)) & _
                            " minute" & IIf(Int(NumOfHMS) = 1, "", "s")
   NumOfHMS = 60 * (NumOfHMS - Int(NumOfHMS))
   YMDHMS = YMDHMS & ", "
   YMDHMS = YMDHMS & CStr(CInt(NumOfHMS)) & _
                            " second" & IIf(Int(NumOfHMS) = 1, "", "s")
End Function