XL 2013 Date avant 1900

maval

maval

XLDnaute Barbatruc
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:

Code: 
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
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
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 :

Code: 
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+
 
Dernière édition:
Vote positif 0 Vote négatif
Modeste geedee

Modeste geedee

XLDnaute Barbatruc
Re : Date avant 1900

Bonsour®
Lone-wolf à dit:
Oublie tout ça tu veux?
À moins de faire un calendrier personnalisé de l'année 1800
(ce dont est impossible).
Cliquez pour agrandir...
:rolleyes:

mais si c'est possible ...
VBA connaît... (à une contrainte près ...:rolleyes:)
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
Cliquez pour agrandir...
Capture.JPG
:rolleyes: un arrière grand oncle y est resté...

VB: 
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
 

Pièces jointes

  • Capture.JPG
    Capture.JPG
    68.3 KB · Affichages: 108
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Date avant 1900

Re,

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

Code: 
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+
 
Dernière édition:
Vote positif 0 Vote négatif
maval

maval

XLDnaute Barbatruc
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,
Code: 
=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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Date avant 1900

Bonjour maval,

Code: 
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+
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
XL 2019 Mélange aléatoire colonne A sur colonne G ne fonctionne pas
Réponses
3
Affichages
113
arvin
A
yojema
  • Question
XL 2021 faire évoluer un code VBA
Réponses
3
Affichages
353
Dranreb
Dranreb
A
  • Résolu(e)
Microsoft 365 Correction du code vba
Réponses
5
Affichages
404
AD95
A
S
  • Résolu(e)
XL 2019 Problème de remplissage cellule en vba
Réponses
5
Affichages
288
snoopy07
S
F
  • Résolu(e)
Microsoft 365 Simplification code
Réponses
2
Affichages
223
Francky79
F
N
  • Résolu(e)
Microsoft 365 Format date d'une textbox vers une cellule
Réponses
8
Affichages
448
ChTi160
ChTi160
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
973
halecs93
halecs93
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
793
Nicolas JACQUIN
Nicolas JACQUIN
cathodique
  • Résolu(e)
XL 2010 Mauvaise utilisation de la fonction InStr
Réponses
11
Affichages
549
jurassic pork
jurassic pork
Nicolas JACQUIN
  • Question
XL 2019 Fusionner jusqu'à dernière colonne contenant
Réponses
8
Affichages
542
TooFatBoy
TooFatBoy

Membres actuellement en ligne

15 membres et 325 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 243
Messages
2 107 673
Membres
109 896
dernier inscrit
Salim KRB