Test date réelle Résolu

Question

Bonjour à tous,

J'ai un fichier Excel où je rentre des dates. 
Afin d'éviter toute faute de frappe, je voudrais faire une macro de type :
Sub Worksheet_Change(ByVal Target As Range).

J'ai tenté d'utiliser la fonction isDate mais celle-ci ne vérifie pas si la date existe réellement, à savoir qu'on peut taper "32/02/14"...

Avez-vous la solution miracle?

Merci d'avance

pijaku · Answer

Bonjour,

Haaa ce problème de dates sous Excel...
32/02/14 est considéré par VBA comme étant le 14 février 2032 donc comme étant une date valide.

Pour pallier ce souci, il nous faut connaitre le ou les formats de saisie que tu utilises.
Soit tu saisis toujours tes dates au format jj/mm/aa soit tu peux en utiliser d'autres.
Par exemple :
mm/jj/aa
jj/mm/aaaa
etc...
Dis nous

geo3701 · Answer

Merci de cette réponse rapide.

J'utilise du jj/mm/aaaa

pijaku · Answer

Réponse un peu moins rapide...
A tester...

Private Sub Worksheet_Change(ByVal Target As Range)
'ici on ne vérifiera les dates que pour la 4ème colonne (D) si la cellule n'est pas vide
If Target.Column <> 4 Or Target.Value = "" Then Exit Sub

If Not EstUneDate(CStr(Target.Value)) Then
    Application.EnableEvents = False
    Target.Value = ""
    Application.EnableEvents = True
    MsgBox "La date saisie n'est pas valide!", vbCritical
End If
End Sub

Function EstUneDate(maDate As String) As Boolean
Dim Jour As Integer, Mois As Integer, Annee As Integer

EstUneDate = False
On Error GoTo TraiteErreur
Jour = CInt(Left(maDate, 2))
If Jour < 1 Then GoTo TraiteErreur
Mois = CInt(Mid(maDate, 4, 2))
If Mois < 1 Or Mois > 12 Then GoTo TraiteErreur
Annee = CInt(Right(maDate, 4))
Select Case Mois
    Case 1, 3, 5, 7, 8, 10, 12 'mois de 31 jours
        If Jour > 31 Then GoTo TraiteErreur
    Case 4, 6, 9, 11 'mois de 30 jours
        If Jour > 30 Then GoTo TraiteErreur
    Case 2 'mois de février
        If Annee Mod 4 = 0 Or Annee Mod 400 = 0 Then
            'années bissextiles
            If Jour > 29 Then GoTo TraiteErreur
        Else
            'années NON bissextiles
            If Jour > 28 Then GoTo TraiteErreur
        End If
End Select
EstUneDate = True
TraiteErreur:
Exit Function
End Function

Sub EnCasDePlantageDeMacro()
    Application.EnableEvents = True
End Sub

Test date réelle

3 réponses

Discussions similaires

Newsletters