XL 2010 VBA - Insérer une date rapidement (6, 7 ou 8 chiffres sans ".")

tchi456

XLDnaute Occasionnel
Bonjour,

Je recherche un code pour pouvoir insérer rapidement une date en 6, 7 ou 8 chiffres sans les "." dans les cellules de la colonne B uniquement.

Exemple: 112022 -> 01.01.2022

J'imaginais adapter ce code qui fonctionne très bien pour insérer rapidement des heures mais ça ne fonctionne malheureusement pas pour la date:

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, UsedRange)
If Target Is Nothing Then Exit Sub
Dim x$
Application.EnableEvents = False 'désactive les évènements
For Each Target In Target 'si entrées multiples

    'Pour insérer une heure rapidement en 3 ou 4 chiffres
    If CStr(Target) Like "###" Or CStr(Target) Like "####" Then
        x = Format(Target, "0000")
        If Left(x, 2) < "24" And Right(x, 2) < "60" Then Target = Left(x, 2) & ":" & Right(x, 2)
    End If
    
    'Pour insérer une date rapidement en 6,7 ou 8 chiffres
     If CStr(Target) Like "######" Or CStr(Target) Like "#######" Or CStr(Target) Like "########" Then
        x = Format(Target, "00000000")
        If Left(x, 2) > "1" And Left(x, 2) < "31" And Mid(x, 2) > "2" And Mid(x, 2) < "12" And Right > "2000" And Right > "3000" Then Target = Left(x, 2) & "." & Mid(x, 2) & "." & Right(x, 4)
    End If
    
Next
Application.EnableEvents = True 'réactive les évènements
End Sub

Avez-vous une astuce qui pourrait m'aider?

Mes meilleures salutations et bon week-end !

Thierry
 

tchi456

XLDnaute Occasionnel
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, UsedRange)
If Target Is Nothing Then Exit Sub
Dim x$
Application.EnableEvents = False 'désactive les évènements
For Each Target In Target 'si entrées multiples

    'Pour insérer une heure rapidement en 3 ou 4 chiffres
    If CStr(Target) Like "###" Or CStr(Target) Like "####" Then
        x = Format(Target, "0000")
        If Left(x, 2) < "24" And Right(x, 2) < "60" Then Target = Left(x, 2) & ":" & Right(x, 2)
    End If
 
    'Pour insérer une date rapidement en 8 chiffres
     If CStr(Target) Like "########" Then
        x = Format(Target, "00000000")
        If Left(x, 2) > "01" < "31" And Mid(x, 2) > "01" < "12" And Right(x, 4) > "2000" < "3000" And Right > "3000" Then Target = Left(x, 2) & "." & Mid(x, 2) & "." & Right(x, 4)
    End If
 
Next
Application.EnableEvents = True 'réactive les évènements
End Sub

Avec ce code ça me renvoie bien une date mais qui ne correspond pas à celle que j'ai inscrit
 

Pièces jointes

  • Exemple.xlsm
    32.7 KB · Affichages: 1
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir tchi456, mapomme,

Essayez ce code :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, [B:B], UsedRange)
If Target Is Nothing Then Exit Sub
Dim x$, y$, dat$
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
For Each Target In Target 'si entrées multiples
    Target.NumberFormat = "General" 'Standard
    x = CStr(Target)
    If x Like "#####" Or x Like "#######" Then x = "0" & x '0 si 5 ou 7 chiffres
    y = Left(x, 2) & "/" & Mid(x, 3, 2) & "/"
    dat = ""
    If x Like "######" Then dat = y & Right(x, 2) '6 chiffres
    If x Like "########" Then dat = y & Right(x, 4) '8 chiffres
    If IsDate(dat) Then
        Target = CDate(dat)
        Target.NumberFormat = "dd.mm.yyyy"
    End If
Next
Application.EnableEvents = True 'réactive les évènements
End Sub
Fonctionne donc quand on entre 5 6 7 ou 8 chiffres.

Edit : curieusement j'ai eu des bugs dépassements de capacité sur x = CStr(Target)

En mettant Target.NumberFormat = "General" avant ça semble régler le problème.

A+
 
Dernière édition:

Discussions similaires

Réponses
4
Affichages
488

Statistiques des forums

Discussions
298 770
Messages
1 971 596
Membres
203 410
dernier inscrit
nicodag