1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
|
Sub Demo()
Dim Valeur As Variant
Dim cel As Range
Dim TypeNumerique As Long
Dim strErreurs As String
Dim annee As Long, mois As Long, jour As Long
Dim hh As Long, mm As Long, ss As Long, hms As String
Dim lngDerniere As Long
lngDerniere = Cells(Rows.Count, 2).End(xlUp).Row + 1
TypeNumerique = 1 '"Date courte" '12/01/2017
Set cel = Cells(lngDerniere, 3)
annee = 2017: mois = 1: jour = 12
Valeur = DateSerial(annee, mois, jour)
strErreurs = EcrireTypeDouble(TypeNumerique, cel, Valeur)
TypeNumerique = 2 '"Date longue" 'vendredi 10 août 2018
Set cel = cel.Offset(, 5)
annee = 2017: mois = 1: jour = 12
Valeur = DateSerial(annee, mois, jour)
strErreurs = EcrireTypeDouble(TypeNumerique, cel, Valeur)
TypeNumerique = 3 '"Date Heure" '12/01/2017 23:05:06
Set cel = cel.Offset(, 5)
hh = 23: mm = 5: ss = 6
annee = 2017: mois = 1: jour = 12
Valeur = TimeSerial(hh, mm, ss) + DateSerial(annee, mois, jour)
strErreurs = EcrireTypeDouble(TypeNumerique, cel, Valeur)
TypeNumerique = 4 '"Heure" '23:05:06
Set cel = cel.Offset(, 5)
hh = 23: mm = 5: ss = 6:
Valeur = TimeSerial(hh, mm, ss)
strErreurs = EcrireTypeDouble(TypeNumerique, cel, Valeur)
TypeNumerique = 5 '"Monetaire"
Set cel = cel.Offset(, 5)
Valeur = -1234567.4567
strErreurs = EcrireTypeDouble(TypeNumerique, cel, Valeur)
TypeNumerique = 6 '"Comptabilite"
Set cel = cel.Offset(, 5)
Valeur = -1234567.4567
strErreurs = EcrireTypeDouble(TypeNumerique, cel, Valeur)
TypeNumerique = 7 '"Pourcentage"
Set cel = cel.Offset(, 5)
Valeur = 1 / 3
strErreurs = EcrireTypeDouble(TypeNumerique, cel, Valeur)
End Sub
Function EcrireTypeDouble(ByVal TypeNumerique As Long, ByVal cel As Range, ByVal Valeur) As String
Dim Titre
Dim ValeurAttendue As Variant
Dim LeTypeAttendu
Dim dblNombre As Double
Dim FormatDeNombre As String
Cells(cel.Row, ActiveCell.Column).Select
dblNombre = Valeur
Select Case TypeNumerique
Case 1: Titre = "Short Date" '12/01/2017
FormatDeNombre = "m/d/yyyy"
cel.NumberFormat = FormatDeNombre 'Typer la cellule avant d'y ecrire une valeur de type Double qui sera convertie
cel.FormulaLocal = CDbl(Valeur) 'Ou bien cel.Value =
LeTypeAttendu = "Date"
Case 2: Titre = "Long Date" 'vendredi 10 août 2018
FormatDeNombre = "[$-F800]dddd, mmmm dd, yyyy"
cel.NumberFormat = FormatDeNombre 'Typer la cellule avant d'y ecrire une valeur de type Double qui sera convertie
cel.FormulaLocal = CDbl(Valeur) 'Ou bien cel.Value =
LeTypeAttendu = "Date"
Case 3: Titre = "Date Heure" '12/01/2017 23:05:06
FormatDeNombre = "m/d/yyyy h:mm"
cel.NumberFormat = FormatDeNombre 'Typer la cellule avant d'y ecrire une valeur de type Double qui sera convertie
cel.FormulaLocal = CDbl(Valeur) 'Ou bien cel.Value =
LeTypeAttendu = "Date"
Case 4: Titre = "Heure" ' 23:05:06
FormatDeNombre = "[$-F400]h:mm:ss AM/PM"
cel.NumberFormat = FormatDeNombre
cel.FormulaLocal = CDbl(Valeur) 'Ou bien cel.Value =
LeTypeAttendu = "Double"
Case 5: Titre = "Monetaire"
If Application.International(xlCurrencyDigits) > 0 Then
cel.NumberFormat = "$#,##0.00_);($#,##0.00)" 'Typer la cellule avant d'y ecrire une valeur de type Double qui sera convertie
Else
cel.NumberFormat = "$#,##0_);($#,##0)"
End If
dblNombre = Application.WorksheetFunction.Round(Valeur, Application.International(xlCurrencyDigits))
cel.FormulaLocal = CDbl(dblNombre) 'Ou bien cel.Value =
LeTypeAttendu = "Currency"
Case 6: Titre = "Comptabilite"
If Application.International(xlCurrencyDigits) > 0 Then
cel.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)" 'Typer la cellule avant d'y ecrire une valeur de type Double qui sera convertie
Else
cel.NumberFormat = "_($* #,##0_);_($* (#,##0);_($* ""-""_);_(@_)"
End If
dblNombre = Application.WorksheetFunction.Round(Valeur, Application.International(xlCurrencyDigits))
cel.FormulaLocal = CDbl(dblNombre) 'Ou bien cel.Value =
LeTypeAttendu = "Currency"
Case 7: Titre = "Pourcentage"
FormatDeNombre = "0.00%"
cel.NumberFormat = FormatDeNombre
cel.FormulaLocal = CDbl(Valeur) 'Ou bien cel.Value =
LeTypeAttendu = "Double"
Case Else
MsgBox "Type numerique inconnu."
Exit Function
End Select
Cells(1, cel.Column + 1) = Titre
If TypeName(cel.Value) <> LeTypeAttendu Then MsgBox "Erreur"
If Math.Abs(cel - dblNombre) <> 0 Then MsgBox "Erreur"
If InStr(cel.Value, "#") Then MsgBox "Erreur"
Call DescriptionCellule(cel, "")
End Function
Function DescriptionCellule(cel As Range, erreur)
cel.Parent.Columns(cel.Column).AutoFit
cel.Offset(, 1) = "'" & cel.Text
cel.Offset(, 2) = "'" & cel.NumberFormat
cel.Offset(, 3) = erreur
cel.Offset(, -1).NumberFormat = ""
cel.Offset(, -1) = Application.International(xlCountrySetting)
cel.Parent.Range(Cells(1, cel.Offset(, -1).Column), cel.Offset(, 3)).Columns.AutoFit
End Function |
Partager