O Renato Santos encaminhou esta função para uso de todos.
Option Compare Database
Option Explicit
' Função para cálculo do intervalo de tempo entre duas datas
' Apresenta o resultado com anos, meses e dias
' Desenvolvida por Renato Santos - rebornbr@msn.com
' Data: Out/05
Function Intervalo(DtI As Date, DtF As Date) As String
If DtF <= DtI Then Exit Function
Dim DataI As Long, DataF As Long
Dim Calculo As String
Dim Anos As Integer, Meses As Integer, Dias As Integer
Dim ComplAnos As String, ComplMeses As String, ComplDias As String
DataI = Format(DtI, "yyyy") & Format(DtI, "mm") & Format(DtI, "dd")
DataF = Format(DtF, "yyyy") & Format(DtF, "mm") & Format(DtF, "dd")
Calculo = Format(DataF - DataI, "00000000")
' Verifica anos
Anos = Left(Calculo, 4)
' Verifica meses
Meses = IIf(Mid(Calculo, 5, 2) < 12, Mid(Calculo, 5, 2), Mid(Calculo, 5, 2) - 88)
' Verifica dias
If Left(DataF, 6) = Left(DataI, 6) Then
Dias = Right(Calculo, 2)
Else
Select Case Mid(DataF, 5, 2)
Case Is = 3
If Day(DateSerial(Left(DataF, 4), 3, 0)) = 29 Then
Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 71)
Else
Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 72)
End If
Case Is = 1, 2, 4, 6, 8, 9, 11
Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 69)
Case Is = 5, 7, 10, 12
Dias = IIf(Right(Calculo, 2) < 31, Right(Calculo, 2), Right(Calculo, 2) - 70)
End Select
End If
' Formata complementos
ComplAnos = IIf(Anos = 0, "", IIf(Anos = 1, " ano", " anos"))
ComplMeses = IIf(Meses = 0, "", IIf(Meses = 1, " mês", " meses"))
ComplDias = IIf(Dias = 0, "", IIf(Dias = 1, " dia", " dias"))
' Formata resultado
If Anos = 0 And Meses = 0 And Dias > 0 Then
Intervalo = Dias & ComplDias
End If
If Anos = 0 And Meses > 0 And Dias = 0 Then
Intervalo = Meses & ComplMeses
End If
If Anos > 0 And Meses = 0 And Dias = 0 Then
Intervalo = Anos & ComplAnos
End If
If Anos > 0 And Meses > 0 And Dias = 0 Then
Intervalo = Anos & ComplAnos & " e " & Meses & ComplMeses
End If
If Anos > 0 And Meses = 0 And Dias > 0 Then
Intervalo = Anos & ComplAnos & " e " & Dias & ComplDias
End If
If Anos = 0 And Meses > 0 And Dias > 0 Then
Intervalo = Meses & ComplMeses & " e " & Dias & ComplDias
End If
If Anos > 0 And Meses > 0 And Dias > 0 Then
Intervalo = Anos & ComplAnos & ", " & Meses & ComplMeses & " e " & Dias & ComplDias
End If
End Function