XL 2013 Date avant 1900

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, r As Range, n&, a$(), x$, y$
Set P = Intersect(Target, [D:G], Me.UsedRange)
If P Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In P 'si entrées multiple (copier-coller)
  n = n + 1
  ReDim Preserve a(1 To 2, 1 To n)
  x = CStr(r.Value2)
  If IsNumeric(x) Then
    y = Format(x, "#0\/00\/0000")
    If (x Like "#######" Or x Like "########") And IsDate(y) Then
      a(1, n) = r.Address
      a(2, n) = Format(y, "m/d/yyyy")
    Else
      Application.Undo 'annulation
      GoTo 1
    End If
  End If
Next r
For n = 1 To UBound(a, 2)
  If a(1, n) <> "" Then
    With Range(a(1, n))
      .Value = a(2, n)
      If Not IsNumeric(.Value2) Then _
      .Value = Format(a(2, n), "dd/mm/yyyy") 'dates avant le calendrier
    End With
  End If
Next n
With Intersect(P.EntireRow, [E:E])
  .FormulaR1C1 = "=IF(NOT(ISBLANK(RC7)),""DCD"",IF(ISNUMBER(RC4),DATEDIF(RC4,TODAY(),""y"")&"" ans"",""""))"
  For Each r In .Areas
    r = r.Value 'supprime les formules
  Next r
End With
1 [D:G].NumberFormat = "dd/mm/yyyy" 'format modifiable
Application.EnableEvents = True
End Sub

Function AgeG(DateDebut, DateFin)
' pour génealogie dates antérieures à 1900
' contrainte arguments : saisie et affichage sous forme jj/mm/aaaa 
Dim dD As Double, dF As Double
If DateDebut.Text Like "*#/##/##*" Then
        dD = DateValue(DateDebut.Text)
        If DateFin.Text Like "*#/##/##*" Then
                dF = DateValue(DateFin.Text)
                AgeG = Int((dF - dD) / 365.25)
        Else
                AgeG = " ? format jj/mm/aaaa"
        End If
Else
        AgeG = " ? format jj/mm/aaaa"
End If
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, r As Range, n&, a$(), x$, y$
Set P = Intersect(Target, [D:G], Me.UsedRange)
If P Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In P 'si entrées multiple (copier-coller)
  n = n + 1
  ReDim Preserve a(1 To 2, 1 To n)
  x = CStr(r.Value2)
  If IsNumeric(x) Then
    y = Format(x, "#0\/00\/0000")
    If (x Like "#######" Or x Like "########") And IsDate(y) Then
      a(1, n) = r.Address
      a(2, n) = Format(y, "m/d/yyyy")
    Else
      Application.Undo 'annulation
      GoTo 1
    End If
  End If
Next r
For n = 1 To UBound(a, 2)
  If a(1, n) <> "" Then
    With Range(a(1, n))
      .Value = a(2, n)
      If Not IsNumeric(.Value2) Then _
      .Value = Format(a(2, n), "dd/mm/yyyy") 'dates avant le calendrier
    End With
  End If
Next n
For Each r In Intersect(P.EntireRow, [D:D])
  r(1, 2) = ""
  If IsDate(r) Then r(1, 2) = DateDiff("yyyy", r, Date) & " ans"
  If CStr(r(1, 4)) <> "" Then r(1, 2) = "DCD"
Next r
1 [D:G].NumberFormat = "dd/mm/yyyy" 'format modifiable
Application.EnableEvents = True
End Sub

=SI(NB(D2:G2)=2;"Décéder à l’âge de : "&DATEDIF(D2;G2;"y")&" an"&REPT("s";DATEDIF(D2;G2;"y")>1);"")

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, r As Range, n&, a$(), x$, y$
Set P = Intersect(Target, [D:H], Me.UsedRange.EntireRow)
If P Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In P 'si entrées multiple (copier-coller)
  n = n + 1
  ReDim Preserve a(1 To 2, 1 To n)
  x = CStr(r.Value2)
  If IsNumeric(x) Then
    y = Format(x, "#0\/00\/0000")
    If (x Like "#######" Or x Like "########") And IsDate(y) Then
      a(1, n) = r.Address
      a(2, n) = Format(y, "m/d/yyyy")
    Else
      Application.Undo 'annulation
      GoTo 1
    End If
  End If
Next r
For n = 1 To UBound(a, 2)
  If a(1, n) <> "" Then
    With Range(a(1, n))
      .Value = a(2, n)
      If Not IsNumeric(.Value2) Then _
      .Value = Format(a(2, n), "dd/mm/yyyy") 'dates avant le calendrier
    End With
  End If
Next n
For Each r In Intersect(P.EntireRow, [D:D])
  Union(r(1, 2), r(1, 5)) = ""
  If IsDate(r) Then
    n = DateDiff("yyyy", r, Date)
    If DateAdd("yyyy", n, r) > Date Then n = n - 1
    r(1, 2) = n & " an" & IIf(n > 1, "s", "")
    If IsDate(r(1, 4)) Then
      r(1, 2) = "DCD"
      n = DateDiff("yyyy", r, r(1, 4))
      If DateAdd("yyyy", n, r) > r(1, 4) Then n = n - 1
      r(1, 5) = "Décédé à l'âge de : " & n & " an" & IIf(n > 1, "s", "")
    End If
  End If
Next r
1 [D:G].NumberFormat = "dd/mm/yyyy" 'format modifiable
Application.EnableEvents = True
End Sub