Código VBA diferenç...
 
Notifications
Clear all

Código VBA diferença entre datas

4 Posts
2 Usuários
0 Reactions
1,284 Visualizações
(@sandrolima)
Posts: 0
Estimable Member
Topic starter
 

Bom dia,colegas do fórum.

Poderiam me ajudar com uma sub-rotina para retornar a diferença em anos e meses entre duas datas.

O Código abaixo traz a informação em anos mas não consegui completar para informar os meses.

Se possível gostaria de considerar a possibilidade do valor unitário também... de trazer a palavra mês (no singular) caso a diferença seja igual a 1 e meses caso seja superior a 1.

O mesmo vale para ano... trazer ano "quando" a diferença for igual a 01 e "anos" quando for superior a 01.

Private Sub txt_DataNasc_AfterUpdate()
txt_Idade = DateDiff("yyyy", txt_DataNasc.Value, Date) & " anos e " & " meses"
End Sub

Muito obrigado a quem puder ajudar.

 
Postado : 28/07/2018 8:43 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

.
Só serve VBA? ... Se não, esta formula resolve ... C1 =DATADIF(A1;B1;"Y")&" ano"&SE(DATADIF(A1;B1;"Y")>1;"s ";" ")&DATADIF(A1;B1;"YM")&" mes"&SE(DATADIF(A1;B1;"YM")>1;"es ";" ")&DATADIF(A1;B1;"MD")&" dia"&SE(DATADIF(A1;B1;"MD")>1;"s ";" ")
.

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 28/07/2018 11:08 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 28/07/2018 2:09 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

.
SandroLima, desculpe a invasão k ...
.
Reinaldo, pode dar uma olhada neste tópico também? ... Obrigado!! .. Os amigos já estão quase resolvendo, mas como sou ansioso, te peço ajuda!! ... Obrigado!! ... viewtopic.php?f=10&t=29119
.

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 28/07/2018 2:51 pm