Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Convertir une date en chiffres en lettres

Convertir une date en chiffres en lettres

5 réponses
Avatar
Apitos
Bonjour =C3=A0 tous,

J'aimerais convertir une date en chiffres en un texte.

Exemple :

17/09/2018 ---> L=E2=80=99an deux mille dix-huit, le dix sept du mois de se=
ptembre.=20

Merci d'avance.
Signaler un problème avec ce contenu

5 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Michd
Bonjour,
Essaie comme ceci. En vba, tu lances la procédure Test. N'oublie pas de spécifier la cellule où est
la date.
Tu peux insérer directement dans une cellule ceci pour obtenir la même chose, mais écris dans la
cellule de ton choix. =convertir(A1)
Le contenu doit être une date reconnue par Excel.
Attention, il se peut que des lignes de code soient coupées par le service de messagerie
'---------------------------------------------
Sub test()
MsgBox Convertir(Range("A1"))
End Sub
'---------------------------------------------
Function Convertir(Rg As Range)
Dim A As Long, D As Long, Mois As String
A = Year(Rg): D = Day(Rg): Mois = Format(Rg, "MMMM")
Convertir = "L'an " & NumText(A) & _
", le " & NumText(D) & _
"du mois de " & Format(D, "MMMM")
End Function
'---------------------------------------------
Function NumText(Nombre As Long, Optional Unité As String, _
Optional SousUnité As String, Optional no_chiffres As Integer, _
Optional Separateur As String) As String
Dim PartieEntière As Currency, PartieDécimal As Currency
Dim TxtEntier As String, TxtDécimal As String
PartieEntière = Int(Nombre)
TxtEntier = NumTextEntier(PartieEntière)
If no_chiffres > 0 Then
PartieDécimal = (Nombre - PartieEntière) * 10 ^ no_chiffres
TxtDécimal = Format(PartieDécimal, String(no_chiffres, "0"))
End If
NumText = TxtEntier
End Function
'---------------------------------------------
Function NumTextEntier(ByVal Entier As Currency) As String
Dim no_Classe As Integer, Classe As Integer
If Entier = 0 Then
NumTextEntier = "Zéro "
Else
While Entier > 0
Classe = Entier - Int(Entier / 1000) * 1000
NumTextEntier = TxtClasse(Classe, no_Classe) & NumTextEntier
no_Classe = no_Classe + 1
Entier = Int(Entier / 1000)
Wend
End If
End Function
'---------------------------------------------
Function TxtClasse(Classe As Integer, no_Classe As Integer) As String
Dim Centaine As Integer, Dizaine As Integer, Unité As Integer, Unités2Chiffres As Integer
Dim TxtCentaines As String, TxtDizaines As String, TxtUnités As String
Dim TClasses As Variant, Tdizaines As Variant, TUnités As Variant
TClasses = Array("", "mille", "million", "milliard", "billion")
Tdizaines = Array("", "", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante",
"quatre-vingt", "quatre-vingt")
TUnités = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", _
"dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit",
"dix-neuf")
If Classe = 0 Then Exit Function
' Pas de un pour mille
If Classe = 1 And no_Classe = 1 Then
TxtClasse = "mille "
Exit Function
End If
Centaine = Classe 100
Unités2Chiffres = Classe Mod 100
Dizaine = Unités2Chiffres 10
Unité = Unités2Chiffres Mod 10
' Les centaines -----
If Centaine = 1 Then
TxtCentaines = "cent "
ElseIf Centaine > 1 Then
TxtCentaines = TUnités(Centaine) & " cent" & IIf(Unités2Chiffres > 0, " ", "s ")
End If
' Les dizaines ------
TxtDizaines = Tdizaines(Dizaine)
If Unité = 1 And Dizaine > 1 And Dizaine < 8 Then
TxtDizaines = TxtDizaines & "-et"
End If
If Dizaine = 1 Or Dizaine = 7 Or Dizaine = 9 Then
Unité = Unité + 10: Dizaine = 0
End If
TxtDizaines = TxtDizaines & IIf(Unités2Chiffres = 80, "s", "")
If Unités2Chiffres > 19 And Unité > 0 Then
TxtDizaines = TxtDizaines & "-"
ElseIf Dizaine > 0 Then
TxtDizaines = TxtDizaines & " "
End If
' Les unités -------- Espace si unité > 0
TxtUnités = TUnités(Unité) & IIf(Unité > 0, " ", "")
' La classe --------- un s sauf pour mille
TxtClasse = TClasses(no_Classe) & IIf(no_Classe > 1 And Classe > 1, "s", "") & IIf(no_Classe >
0, " ", "")
' Résultat ----------
TxtClasse = TxtCentaines & TxtDizaines & TxtUnités & TxtClasse
End Function
'---------------------------------------------
=========================================================
La fonction originale fait ceci :
Voici quelques exemples en VBA.
Tu peux faire la même chose en appelant la fonction NumText dans une cellule...
=NumText(A1;"euros";"centimes";2;" et ")
'---------------------------------------------
Sub Exemple()
' "deux cent cinquante-six mille trois cent vingt-quatre"
MsgBox NumText(256324)
'"quatre cent trente francs et 50 centimes"
MsgBox NumText(1430569125.5, "Dollars", "cents", 2, " et ")
'
MsgBox NumText(430.5, "francs", "centimes", 2, " et ")
'"quatre cent trente francs 50 centimes"
MsgBox NumText(430.5, "francs", "centimes", 2, " ")
End Sub
'---------------------------------------------
Function NumText(Nombre As Currency, Optional Unité As String, _
Optional SousUnité As String, Optional no_chiffres As Integer, _
Optional Separateur As String) As String
Dim PartieEntière As Currency, PartieDécimal As Currency
Dim TxtEntier As String, TxtDécimal As String
PartieEntière = Int(Nombre)
TxtEntier = NumTextEntier(PartieEntière)
If no_chiffres > 0 Then
PartieDécimal = (Nombre - PartieEntière) * 10 ^ no_chiffres
TxtDécimal = Format(PartieDécimal, String(no_chiffres, "0"))
End If
NumText = TxtEntier & Unité & Separateur & TxtDécimal & " " & SousUnité
End Function
Function NumTextEntier(ByVal Entier As Currency) As String
Dim no_Classe As Integer, Classe As Integer
If Entier = 0 Then
NumTextEntier = "Zéro "
Else
While Entier > 0
Classe = Entier - Int(Entier / 1000) * 1000
NumTextEntier = TxtClasse(Classe, no_Classe) & NumTextEntier
no_Classe = no_Classe + 1
Entier = Int(Entier / 1000)
Wend
End If
End Function
'---------------------------------------------
Function TxtClasse(Classe As Integer, no_Classe As Integer) As String
Dim Centaine As Integer, Dizaine As Integer, Unité As Integer, Unités2Chiffres As Integer
Dim TxtCentaines As String, TxtDizaines As String, TxtUnités As String
Dim TClasses As Variant, Tdizaines As Variant, TUnités As Variant
TClasses = Array("", "mille", "million", "milliard", "billion")
Tdizaines = Array("", "", "vingt", "trente", "quarante", "cinquante", "soixante", "soixante",
"quatre-vingt", "quatre-vingt")
TUnités = Array("", "un", "deux", "trois", "quatre", "cinq", "six", "sept", "huit", "neuf", _
"dix", "onze", "douze", "treize", "quatorze", "quinze", "seize", "dix-sept", "dix-huit",
"dix-neuf")
If Classe = 0 Then Exit Function
' Pas de un pour mille
If Classe = 1 And no_Classe = 1 Then
TxtClasse = "mille "
Exit Function
End If
Centaine = Classe 100
Unités2Chiffres = Classe Mod 100
Dizaine = Unités2Chiffres 10
Unité = Unités2Chiffres Mod 10
' Les centaines -----
If Centaine = 1 Then
TxtCentaines = "cent "
ElseIf Centaine > 1 Then
TxtCentaines = TUnités(Centaine) & " cent" & IIf(Unités2Chiffres > 0, " ", "s ")
End If
' Les dizaines ------
TxtDizaines = Tdizaines(Dizaine)
If Unité = 1 And Dizaine > 1 And Dizaine < 8 Then
TxtDizaines = TxtDizaines & "-et"
End If
If Dizaine = 1 Or Dizaine = 7 Or Dizaine = 9 Then
Unité = Unité + 10: Dizaine = 0
End If
TxtDizaines = TxtDizaines & IIf(Unités2Chiffres = 80, "s", "")
If Unités2Chiffres > 19 And Unité > 0 Then
TxtDizaines = TxtDizaines & "-"
ElseIf Dizaine > 0 Then
TxtDizaines = TxtDizaines & " "
End If
' Les unités -------- Espace si unité > 0
TxtUnités = TUnités(Unité) & IIf(Unité > 0, " ", "")
' La classe --------- un s sauf pour mille
TxtClasse = TClasses(no_Classe) & IIf(no_Classe > 1 And Classe > 1, "s", "") & IIf(no_Classe >
0, " ", "")
' Résultat ----------
TxtClasse = TxtCentaines & TxtDizaines & TxtUnités & TxtClasse
End Function
'---------------------------------------------
MichD
Avatar
Apitos
Bonjour MichD,
Merci pour la solution.
J'ai adapté la fonction Convertir(), pour le "de" avec apostrophe ou p as selon le mois :
'---------------------------------------------
Function Convertir(Rg As Range)
Dim A As Long, D As Long, Mois As String
Dim aps As String
A = Year(Rg): D = Day(Rg): Mois = Format(Rg, "MMMM")
moisTab = Array("avril", "août", "octobre")
p = Application.Match(Mois, moisTab, 0)
If IsError(p) Then
aps = "de "
Else: aps = "d'"
End If
Convertir = "L'an " & NumText(A) & _
", le " & NumText(D) & _
"du mois " & aps & Mois
End Function
'------------------------------------------------
Merci encore
Avatar
Fredo P.
Le 18/09/2018 à 01:23, Apitos a écrit :
Bonjour MichD,
Merci pour la solution.
J'ai adapté la fonction Convertir(), pour le "de" avec apostrophe ou pas selon le mois :
'---------------------------------------------
Function Convertir(Rg As Range)
Dim A As Long, D As Long, Mois As String
Dim aps As String
A = Year(Rg): D = Day(Rg): Mois = Format(Rg, "MMMM")
moisTab = Array("avril", "août", "octobre")
p = Application.Match(Mois, moisTab, 0)
If IsError(p) Then
aps = "de "
Else: aps = "d'"
End If
Convertir = "L'an " & NumText(A) & _
", le " & NumText(D) & _
"du mois " & aps & Mois
End Function
'------------------------------------------------
Merci encore

Le zip est dispo sur "comment ça marche" aussi je l'ai mis sur cjoint
https://www.cjoint.com/c/HJknac0QcoV
--
Fredo P.
http://cdrm4f.jimdo.com
Avatar
Fredo P.
Le 18/09/2018 à 01:23, Apitos a écrit :
Bonjour MichD,
Merci pour la solution.
J'ai adapté la fonction Convertir(), pour le "de" avec apostrophe ou pas selon le mois :
'---------------------------------------------
Function Convertir(Rg As Range)
Dim A As Long, D As Long, Mois As String
Dim aps As String
A = Year(Rg): D = Day(Rg): Mois = Format(Rg, "MMMM")
moisTab = Array("avril", "août", "octobre")
p = Application.Match(Mois, moisTab, 0)
If IsError(p) Then
aps = "de "
Else: aps = "d'"
End If
Convertir = "L'an " & NumText(A) & _
", le " & NumText(D) & _
"du mois " & aps & Mois
End Function
'------------------------------------------------
Merci encore

J'en oublie le principal, Laurent longre a mis à dispo un complément de
formules Morfunc dont l'une (NbTexte) fait cette opération.
--
Fredo P.
http://cdrm4f.jimdo.com
Avatar
Jacquouille
Bonjour Fredo
Tu as des nouvelles de Laurent Longres, notre chef à 4 plumes?
Jacques
" Le vin est au repas ce que le parfum est à la femme."
.
"Fredo P." a écrit dans le message de groupe de discussion :
Le 18/09/2018 à 01:23, Apitos a écrit :
Bonjour MichD,
Merci pour la solution.
J'ai adapté la fonction Convertir(), pour le "de" avec apostrophe ou pas
selon le mois :
'---------------------------------------------
Function Convertir(Rg As Range)
Dim A As Long, D As Long, Mois As String
Dim aps As String
A = Year(Rg): D = Day(Rg): Mois = Format(Rg, "MMMM")
moisTab = Array("avril", "août", "octobre")
p = Application.Match(Mois, moisTab, 0)
If IsError(p) Then
aps = "de "
Else: aps = "d'"
End If
Convertir = "L'an " & NumText(A) & _
", le " & NumText(D) & _
"du mois " & aps & Mois
End Function
'------------------------------------------------
Merci encore

J'en oublie le principal, Laurent longre a mis à dispo un complément de
formules Morfunc dont l'une (NbTexte) fait cette opération.
--
Fredo P.
http://cdrm4f.jimdo.com