XL 2013 Date avant 1900

[maval]

Bonjour

Je doit rentré des dates dans ma feuille Excel en colonne " D & G" certaine sont avant l'année 1900 excel ne me les accepte pas?

J'ai un code pour rentré les dates qui est ceci:

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 = "" 'autre cas d'annulation
     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

Je vous remercie

 

[Lone-wolf]

Re : Date avant 1900

Max, Max, Max

Oublie tout ça tu veux? À moins de faire un calendrier personnalisé de l'année 1800(ce dont est impossible).

 

[Simply]

Re : Date avant 1900

Ciao

Avant d'abandonner les tests:
Vous devez saisir l'adresse pour télécharger exemple
How to Work With Dates Before 1900 in Excel

Attention, vous devez entrer des dates antérieures sous forme de texte dans la langue utilisée dans le pays

 

[Modeste geedee]

Re : Date avant 1900

Bonsour®
voir là :
Excel Downloads From John Walkenbach: Extended Date Functions (XDATE)

 

[job75]

Re : Date avant 1900

Bonjour maval, Lone_wolf, Simply, [Edit] Modeste geedee

Pourquoi ne pas rester sur le même fil, ce serait plus compréhensible non ?

Le 2ème cas d'annulation c'est justement pour les dates avant le début du calendrier utilisé (1900 ou 1904).

On peut les afficher mais elles seront sous forme de textes, et l'on ne pourra rien en faire :

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

L'âge en colonne E ne sera pas calculé.

A+

 

[Modeste geedee]

Re : Date avant 1900

Bonsour®

Oublie tout ça tu veux?
À moins de faire un calendrier personnalisé de l'année 1800
(ce dont est impossible).

🙄

mais si c'est possible ...
VBA connaît... (à une contrainte près ...🙄)

Les variables de type Date sont stockées sous la forme de nombres à virgule flottante de 64 bits (8 octets) IEEE représentant des dates comprises entre le 1er janvier 100 et le 31 décembre 9999

🙄 un arrière grand oncle y est resté...

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

 

[job75]

Re : Date avant 1900

Re,

Cela dit on peut traiter les dates antérieures au calendrier en faisant tous les calculs en VBA :

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

Ici on n'utilise plus la formule avec DATEDIF dans la feuille de calcul.

A+

 

[maval]

Re : Date avant 1900

Bonjour Job

Je m'excuse de ne pas avoir répondu avant je vous remercie sa fonctionne nickel.
Par contre j'ai une formule sur la colonne "H" qui ne fonctionne plus,

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

Peut-on l'ajouter dans le code?
Si oui pouvez vous m'aider

Merci et bon dimanche

 

[job75]

Re : Date avant 1900

Bonjour maval,

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

En fait DateDiff calcule les années entre la 1ère date et le 31/12 de l'année de la 2ème !!!

Il faut donc faire une petite gymnastique avec DateAdd pour tester.

Edit : avec [D:H] au début la colonne H ne peut pas être modifiée.

A+

 

[maval]

Re : Date avant 1900

Bonjour

je vous remercie Nickel
Bonne journée