talvez:
'****************************************************************
'
'http://jjoao2k.no.sapo.pt
'
'Feito por JJoão
'Data : 28/03/2001
'Objectivo : Resposta a pedido de ajuda de calculo de diferença
' entre duas datas
' Adicionar ou remover anos e /ou meses e/ou dias a
' uma data
'****************************************************************
Function DatasDif(DataInicial As Date, DataFinal As Date) As String
Dim AnoDif As Integer, MêsDif As Integer, DiaDif As Integer
Dim StrAno As String, StrMês As String, StrDia As String
Dim SepAno As String, Sep As String
Dim Chave As String
Dim tmp As Date
Dim anos, meses, dias
'strings para plural e singular
anos = Array("", "ano", "anos")
meses = Array("", "mês", "meses")
dias = Array("", "dia", "dias")
'só calcula se for uma data válida
If IsDate(DataInicial) = False Or IsDate(DataFinal) = False Then
DatasDif = "-"
Exit Function
End If
'Tratamento do(s) ano(s)
AnoDif = Year(DataFinal) - Year(DataInicial)
If DateSerial(Year(DataFinal), _
Month(DataInicial), _
Day(DataInicial)) > DataFinal Then AnoDif = AnoDif - 1
'Tratamento do mês
If Month(DataFinal) > Month(DataInicial) Then
If Day(DataFinal) >= Day(DataInicial) Then
MêsDif = Month(DataFinal) - Month(DataInicial)
Else
MêsDif = Month(DataFinal) - Month(DataInicial) - 1
End If
Else
If Day(DataFinal) >= Day(DataInicial) Then
MêsDif = Month(DataFinal) - Month(DataInicial) + 12
If MêsDif = 12 Then MêsDif = 0
Else
MêsDif = Month(DataFinal) - Month(DataInicial) + 11
End If
End If
'Tratamento dos dias
If Day(DataFinal) >= Day(DataInicial) Then
DiaDif = Day(DataFinal) - Day(DataInicial)
Else
DiaDif = Day(DateSerial(Year(DataInicial), Month(DataInicial) + 1, 1) - 1) - Day(DataInicial) + Day(DataFinal)
End If
'Construção de uma Chave para facilitar o tratamento da string
If AnoDif > 0 Then Chave = "S" Else Chave = "N"
If MêsDif > 0 Then Chave = Chave & "S" Else Chave = Chave & "N"
If DiaDif > 0 Then Chave = Chave & "S" Else Chave = Chave & "N"
Sep = " e " 'separador variavel consoante valores de meses e/ou dias
Select Case Chave
Case "SSS"
SepAno = ", "
Case "NSS", "SNS", "SSN"
SepAno = Sep
End Select
'Ano(s)
If AnoDif > 0 Then StrAno = AnoDif & " " & anos(maior(AnoDif)) & SepAno
'Mês(es)
If MêsDif > 0 Then StrMês = MêsDif & " " & meses(maior(MêsDif)) & Sep
'Dia(s)
If DiaDif > 0 Then StrDia = DiaDif & " " & dias(maior(DiaDif))
DatasDif = StrAno & StrMês & StrDia
End Function
Function maior(n As Integer) As Integer
'usado pela função DatasDif para controlar o singular e o plural
'na construção da string formatada do extenso
If n > 1 Then maior = 2 Else maior = 1
End Function
Ou ainda:
Function AnoMesDia(dataNasc As String) As String
' Fornece a idade em anos, meses e dias
On Error GoTo AnoMesDia_Err
Dim sTmp As String ' valor tmp da função
Dim nDMA As Long ' n Anos, Meses, Dias
Dim NewDate As Date ' data auxiliar de cálculo
Dim sSngPlural As String ' string (mês, meses), (ano, anos)
Dim dtData1 As Date ' data inicial de cálculo
Dim dtData2 As Date ' data final
' Se dataNasc não é data, interrompe
If Not IsDate(dataNasc) Then
AnoMesDia = "Erro: data inválida."
Exit Function
End If
dtData1 = CDate(dataNasc)
dtData2 = Now
' Bloco Ano ---------------------
' Calcula número inteiro de anos
nDMA = DateDiff("yyyy", dtData1, dtData2)
' Se Data1+nDMA>Data2, subtrai 1 ano
If DateAdd("yyyy", nDMA, dtData1) > dtData2 Then
nDMA = nDMA - 1
End If
sSngPlural = " ano, "
If nDMA > 1 Then sSngPlural = " anos, "
sTmp = CStr(nDMA) & sSngPlural
' Bloco Mês ---------------------
' Nova data de referência
NewDate = DateAdd("yyyy", nDMA, dtData1)
nDMA = DateDiff("m", NewDate, dtData2)
' Se Data1+nDMA>Data2, subtrai 1 mês
If DateAdd("m", nDMA, NewDate) > dtData2 Then
nDMA = nDMA - 1
End If
sSngPlural = " mês e "
If nDMA > 1 Then sSngPlural = " meses e "
sTmp = sTmp & CStr(nDMA) & sSngPlural
' Bloco Dia ---------------------
NewDate = DateAdd("m", nDMA, NewDate)
nDMA = DateDiff("d", NewDate, dtData2)
sSngPlural = " dia"
If nDMA > 1 Then sSngPlural = " dias"
sTmp = sTmp & CStr(nDMA) & sSngPlural
' Valor final da função
AnoMesDia = sTmp
AnoMesDia_Fim:
Exit Function
AnoMesDia_Err:
MsgBox Err.Description
Resume AnoMesDia_Fim
End Function
Postado : 28/07/2018 2:09 pm