XL 2010 DateRepublicaine

cricri3131

XLDnaute Nouveau
J'essaye d'utiliser la fonction de conversion de date : calendrier républicain vers calendrier grégorien (le notre actuel), et ça ne marche pas, ne connaissant que très très peu VBA, je n'arrive pas à debugger.


Dans ma cellule d'entrée, j'ai par exemple : 25 nivose an 8. Je suppose que ce format ne convient pas à la fonction telle qu'elle est. Mais je ne sais pas quel format conviendrai ni quoi modifier dans la fonction pour l'adapter à ce format.

Merci par avance pour une réponse.
 
Solution
C
Re,
Voici le code entier avec la fonction modifiée ;)
VB:
Option Explicit

Function AnalyserDate(AAnneeR As Integer, AMoisR As Integer, AJourR As Integer) As String
Dim strDateG As String
Dim intAnnee As Integer, intMois As Integer, intJour As Integer
Dim lngJourBasic As Long
Const JourBasicOffset = -39545 'Valeur magique calculée pour faire correspondre 1er vendémiaire an I et 22/9/1792
Const JoursPar4ans = 1461
Const JoursParMois = 30
' Vérifications au départ :  On n'accepte que les années entre 1 et 14.
'  Selon Wikipedia, il n'y aurait pas consensus sur la détermination (virtuelle) des années "sextiles"
'  (avec 6 jours complémentaires) si le calendrier avait été utilisé au delà de l'an 14.
If (AAnneeR < 1) Or (AAnneeR > 14) Then...

VIARD

XLDnaute Impliqué
Bonjour Cricri, Bambi, Roblochon, Bruno et à tous

Il y a quelque temps je me suis lancé dans ce truc, en prélevant au passage
des fonctions de "Roger227" (avec son accord).
J'espère qu'il n'y a pas trop de boulettes.

A+ Jean-Paul
 

Pièces jointes

  • Conv_Grégorien_Républicain.zip
    421 KB · Affichages: 6

cricri3131

XLDnaute Nouveau
C

Compte Supprimé 979

Guest
Re,
Voici le code entier avec la fonction modifiée ;)
VB:
Option Explicit

Function AnalyserDate(AAnneeR As Integer, AMoisR As Integer, AJourR As Integer) As String
Dim strDateG As String
Dim intAnnee As Integer, intMois As Integer, intJour As Integer
Dim lngJourBasic As Long
Const JourBasicOffset = -39545 'Valeur magique calculée pour faire correspondre 1er vendémiaire an I et 22/9/1792
Const JoursPar4ans = 1461
Const JoursParMois = 30
' Vérifications au départ :  On n'accepte que les années entre 1 et 14.
'  Selon Wikipedia, il n'y aurait pas consensus sur la détermination (virtuelle) des années "sextiles"
'  (avec 6 jours complémentaires) si le calendrier avait été utilisé au delà de l'an 14.
If (AAnneeR < 1) Or (AAnneeR > 14) Then
   strDateG = "Date hors champ de conversion"
ElseIf (AMoisR < 1) Or (AMoisR > 13) Then
' On notera que les jours complémentaires sont affectés à un mois fictif. Pas de vérif des années "sextiles"
ElseIf (AJourR < 1) Or (AJourR > 30) Or ((AJourR > 6) And (13 = AMoisR)) Then
Else
  ' A partir d'ici, j'applique la formule magique de Monsieur Scott E Lee
   lngJourBasic = Int((AAnneeR * JoursPar4ans) / 4) + (AMoisR - 1) * JoursParMois + AJourR + JourBasicOffset
   intAnnee = Year(lngJourBasic)
   intMois = Month(lngJourBasic)
   intJour = Day(lngJourBasic)
   strDateG = Format(intJour, "00") & "/" & Format(intMois, "00") & "/" & Format(intAnnee, "0000")
End If
AnalyserDate = strDateG
End Function

Private Function NumeroMois(ByVal ANomMoisR As String, ByRef ARepublicain As Boolean) As Integer
Dim intRangMoisR As Integer
Dim strNomMoisR  As String
Select Case UCase(Left$(Trim(ANomMoisR), 4))
   Case "VEND", "VD", "JANV", "JAN", "JANU"
     intRangMoisR = 1
   Case "BRUM", "BR", "FEV", "FEB", "FEVR", UCase("FéVR"), "FEBR"
      intRangMoisR = 2
   Case "FRIM", "FRI", "MARS", "MAR", "MARC", "MA"
       intRangMoisR = 3
   Case "NIVO", "NIV", UCase("NIVô"), "NI", "AVRI", "AVR", "APR", "APRI"
      intRangMoisR = 4
   Case "PLUV", "PLU", "PL", "MAI", "MAY"
       intRangMoisR = 5
   Case "VENT", "VEN", "VE", "JUIN", "JUN", "JUNE"
      intRangMoisR = 6
   Case "GERM", "GE", "JUIL", "JULY", "JUL"
       intRangMoisR = 7
   Case "FLOR", "FLO", "FL", "AOUT", "AOU", "AUG", "AOÛT"
      intRangMoisR = 8
   Case "PRAI", "PRA", "PR", "SEPT", "SEP"
     intRangMoisR = 9
   Case "MESS", "MES", "ME", "OCTO", "OCT"
      intRangMoisR = 10
   Case "THER", "THE", "TH", "NOV", "NOVE"
       intRangMoisR = 11
   Case "FRUC", "FRU", "FR", "DEC", "DECE", UCase("DéCE")
      intRangMoisR = 12
   Case "COMP", "CO"
      intRangMoisR = 13
   Case Else
      intRangMoisR = 0
End Select
Select Case UCase(Left$(Trim(ANomMoisR), 1))
   Case "V", "B", "G", "P", "T", "C"
     ARepublicain = True
   Case Else
     Select Case UCase(Left$(Trim(ANomMoisR), 2))
     Case "NI", "ME", "FR", "FL"
       ARepublicain = True
     Case Else
       ARepublicain = False
     End Select
End Select
NumeroMois = intRangMoisR
End Function

' Code modifié par BrunoM45
Public Function DateRepublicaine(AChaineDate As String) As String
  Dim strSeparateur  As String
  Dim sDateDeb As String, sAnnée As String, sTmp As String
  Dim IndAn As Integer, TabAn As Variant
  Dim varContenuDate As Variant
  Dim intContenu     As Integer
  Dim intMoisR       As Integer
  Dim intJourR       As Integer
  Dim intAnneeR      As Integer
  Dim blnRepublicain As Boolean
  Dim strMois        As String
  ' Recalcul auto
  Application.Volatile
  'Quel est le séparateur
  strSeparateur = ChercherSeparateur(AChaineDate)
  'Découper la date en éléments séparés
  varContenuDate = Split(AChaineDate, strSeparateur)
  'Combien d'éléments ?
  intContenu = UBound(varContenuDate)
  If intContenu = 2 Then
    If IsNumeric(varContenuDate(1)) Then
      intMoisR = CInt(varContenuDate(1))
    Else
      intMoisR = NumeroMois(CStr(varContenuDate(1)), blnRepublicain)
    End If
    If IsNumeric(varContenuDate(2)) Then intAnneeR = CInt(varContenuDate(2))
  Else
    intMoisR = NumeroMois(CStr(varContenuDate(1)), blnRepublicain)
    If IsNumeric(varContenuDate(3)) Then
      intAnneeR = CInt(varContenuDate(3))
    Else
      TabAn = Split("I,II,III,IV,V,VI,VII,VIII,IX,X,XI,XII,XIII,XIV", ",")
      IndAn = 0
      Do While TabAn(IndAn) <> varContenuDate(3)
        IndAn = IndAn + 1
      Loop
      intAnneeR = IndAn + 1
    End If
  End If
  If IsNumeric(varContenuDate(0)) Then intJourR = CInt(varContenuDate(0))
  If blnRepublicain Then
    DateRepublicaine = AnalyserDate(intAnneeR, intMoisR, intJourR)
  Else
    DateRepublicaine = Format(intAnneeR, "0000") & "/" & Format(intMoisR, "00") & "/" & Format(intJourR, "00")
  End If
End Function

Private Function ChercherSeparateur(AChaineDate As String) As String
If InStr(1, AChaineDate, "/") > 0 Then
   ChercherSeparateur = "/"
ElseIf InStr(1, AChaineDate, "-") > 0 Then
   ChercherSeparateur = "-"
ElseIf InStr(1, AChaineDate, " ") > 0 Then
   ChercherSeparateur = " "
ElseIf InStr(1, AChaineDate, ".") > 0 Then
   ChercherSeparateur = "."
ElseIf InStr(1, AChaineDate, "_") > 0 Then
   ChercherSeparateur = "_"
End If
End Function

Tu appelles ta fonction simplement
Code:
=daterepublicaine(A2)

Et voilà ce que ça donne
2021-02-05_17h36_03.png


@+
 

cricri3131

XLDnaute Nouveau
Re,
Voici le code entier avec la fonction modifiée ;)
VB:
Option Explicit

Function AnalyserDate(AAnneeR As Integer, AMoisR As Integer, AJourR As Integer) As String
Dim strDateG As String
Dim intAnnee As Integer, intMois As Integer, intJour As Integer
Dim lngJourBasic As Long
Const JourBasicOffset = -39545 'Valeur magique calculée pour faire correspondre 1er vendémiaire an I et 22/9/1792
Const JoursPar4ans = 1461
Const JoursParMois = 30
' Vérifications au départ :  On n'accepte que les années entre 1 et 14.
'  Selon Wikipedia, il n'y aurait pas consensus sur la détermination (virtuelle) des années "sextiles"
'  (avec 6 jours complémentaires) si le calendrier avait été utilisé au delà de l'an 14.
If (AAnneeR < 1) Or (AAnneeR > 14) Then
   strDateG = "Date hors champ de conversion"
ElseIf (AMoisR < 1) Or (AMoisR > 13) Then
' On notera que les jours complémentaires sont affectés à un mois fictif. Pas de vérif des années "sextiles"
ElseIf (AJourR < 1) Or (AJourR > 30) Or ((AJourR > 6) And (13 = AMoisR)) Then
Else
  ' A partir d'ici, j'applique la formule magique de Monsieur Scott E Lee
   lngJourBasic = Int((AAnneeR * JoursPar4ans) / 4) + (AMoisR - 1) * JoursParMois + AJourR + JourBasicOffset
   intAnnee = Year(lngJourBasic)
   intMois = Month(lngJourBasic)
   intJour = Day(lngJourBasic)
   strDateG = Format(intJour, "00") & "/" & Format(intMois, "00") & "/" & Format(intAnnee, "0000")
End If
AnalyserDate = strDateG
End Function

Private Function NumeroMois(ByVal ANomMoisR As String, ByRef ARepublicain As Boolean) As Integer
Dim intRangMoisR As Integer
Dim strNomMoisR  As String
Select Case UCase(Left$(Trim(ANomMoisR), 4))
   Case "VEND", "VD", "JANV", "JAN", "JANU"
     intRangMoisR = 1
   Case "BRUM", "BR", "FEV", "FEB", "FEVR", UCase("FéVR"), "FEBR"
      intRangMoisR = 2
   Case "FRIM", "FRI", "MARS", "MAR", "MARC", "MA"
       intRangMoisR = 3
   Case "NIVO", "NIV", UCase("NIVô"), "NI", "AVRI", "AVR", "APR", "APRI"
      intRangMoisR = 4
   Case "PLUV", "PLU", "PL", "MAI", "MAY"
       intRangMoisR = 5
   Case "VENT", "VEN", "VE", "JUIN", "JUN", "JUNE"
      intRangMoisR = 6
   Case "GERM", "GE", "JUIL", "JULY", "JUL"
       intRangMoisR = 7
   Case "FLOR", "FLO", "FL", "AOUT", "AOU", "AUG", "AOÛT"
      intRangMoisR = 8
   Case "PRAI", "PRA", "PR", "SEPT", "SEP"
     intRangMoisR = 9
   Case "MESS", "MES", "ME", "OCTO", "OCT"
      intRangMoisR = 10
   Case "THER", "THE", "TH", "NOV", "NOVE"
       intRangMoisR = 11
   Case "FRUC", "FRU", "FR", "DEC", "DECE", UCase("DéCE")
      intRangMoisR = 12
   Case "COMP", "CO"
      intRangMoisR = 13
   Case Else
      intRangMoisR = 0
End Select
Select Case UCase(Left$(Trim(ANomMoisR), 1))
   Case "V", "B", "G", "P", "T", "C"
     ARepublicain = True
   Case Else
     Select Case UCase(Left$(Trim(ANomMoisR), 2))
     Case "NI", "ME", "FR", "FL"
       ARepublicain = True
     Case Else
       ARepublicain = False
     End Select
End Select
NumeroMois = intRangMoisR
End Function

' Code modifié par BrunoM45
Public Function DateRepublicaine(AChaineDate As String) As String
  Dim strSeparateur  As String
  Dim sDateDeb As String, sAnnée As String, sTmp As String
  Dim IndAn As Integer, TabAn As Variant
  Dim varContenuDate As Variant
  Dim intContenu     As Integer
  Dim intMoisR       As Integer
  Dim intJourR       As Integer
  Dim intAnneeR      As Integer
  Dim blnRepublicain As Boolean
  Dim strMois        As String
  ' Recalcul auto
  Application.Volatile
  'Quel est le séparateur
  strSeparateur = ChercherSeparateur(AChaineDate)
  'Découper la date en éléments séparés
  varContenuDate = Split(AChaineDate, strSeparateur)
  'Combien d'éléments ?
  intContenu = UBound(varContenuDate)
  If intContenu = 2 Then
    If IsNumeric(varContenuDate(1)) Then
      intMoisR = CInt(varContenuDate(1))
    Else
      intMoisR = NumeroMois(CStr(varContenuDate(1)), blnRepublicain)
    End If
    If IsNumeric(varContenuDate(2)) Then intAnneeR = CInt(varContenuDate(2))
  Else
    intMoisR = NumeroMois(CStr(varContenuDate(1)), blnRepublicain)
    If IsNumeric(varContenuDate(3)) Then
      intAnneeR = CInt(varContenuDate(3))
    Else
      TabAn = Split("I,II,III,IV,V,VI,VII,VIII,IX,X,XI,XII,XIII,XIV", ",")
      IndAn = 0
      Do While TabAn(IndAn) <> varContenuDate(3)
        IndAn = IndAn + 1
      Loop
      intAnneeR = IndAn + 1
    End If
  End If
  If IsNumeric(varContenuDate(0)) Then intJourR = CInt(varContenuDate(0))
  If blnRepublicain Then
    DateRepublicaine = AnalyserDate(intAnneeR, intMoisR, intJourR)
  Else
    DateRepublicaine = Format(intAnneeR, "0000") & "/" & Format(intMoisR, "00") & "/" & Format(intJourR, "00")
  End If
End Function

Private Function ChercherSeparateur(AChaineDate As String) As String
If InStr(1, AChaineDate, "/") > 0 Then
   ChercherSeparateur = "/"
ElseIf InStr(1, AChaineDate, "-") > 0 Then
   ChercherSeparateur = "-"
ElseIf InStr(1, AChaineDate, " ") > 0 Then
   ChercherSeparateur = " "
ElseIf InStr(1, AChaineDate, ".") > 0 Then
   ChercherSeparateur = "."
ElseIf InStr(1, AChaineDate, "_") > 0 Then
   ChercherSeparateur = "_"
End If
End Function

Tu appelles ta fonction simplement
Code:
=daterepublicaine(A2)

Et voilà ce que ça donne
Regarde la pièce jointe 1094440

@+
Merci beaucoup, c'est exactement ce qu'il me fallait. Je l'ai testé sur des dates converties une à une sur des sites en ligne, ça m'a permis de rectifier deux erreurs que j'avais commises (ah les copiers collés !!!) et corriger les relevés, deux cases ne fonctionnaient pas, elles étaient vides. En fait le releveur avait noté "termidor" sans le "h".
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

[aparté]
Il y a quelque temps je me suis lancé dans ce truc, en prélevant au passage
des fonctions de "Roger227" (avec son accord).
VIARD
Petite question indiscrète au passage
Tu as eu un accord récent de Roger2327?
Ou cela fait un bail?
Je dis cela parce qu'on ne lit plus ROGER2327 sur le forum depuis longtemps.
Mais je serais content d'apprendre que tout roule pour lui.
;)
[/aparté]
 

VIARD

XLDnaute Impliqué
Bonsoir Staple, Dranreb et à tous

Non il n'y a pas de question indiscrète, il y a un bail qu'on ne le voit plus.
c'est bien dommage, à l'époque je suis entré en contact, je ne voulais pas utiliser ses fonctions sans son
assentiment, que devient-il ?
Donc je suis comme toi.

A+ Jean-Paul
 

Roland_M

XLDnaute Barbatruc
Bonsoir le fil

[aparté]

VIARD
Petite question indiscrète au passage
Tu as eu un accord récent de Roger2327?
Ou cela fait un bail?
Je dis cela parce qu'on ne lit plus ROGER2327 sur le forum depuis longtemps.
Mais je serais content d'apprendre que tout roule pour lui.
;)
[/aparté]
Bien le bonjour à tous,

Je viens de tomber, par hasard, sur ce fil ...
Effectivement je me demandais aussi "on ne voit plus notre ami Roger2327 !?"
J'espère que tout va bien pour lui ? Peut être son état de santé !?
C'est un personnage de grande valeur !

Et il n'y a personne pour se renseigner, quelqu'un de plus intime sur ce forum !?
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 900
Membres
101 834
dernier inscrit
Jeremy06510