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

tchi456 · 21 Janvier 2022

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

mapomme · 21 Janvier 2022

Bonsoir,

Date à 7 chiffres ? 1112022 représente le 11 janvier 2022 ou bien le 1er novembre 2022 ?

tchi456 · 21 Janvier 2022

mapomme à dit:
Bonsoir,

Date à 7 chiffres ? 1112022 représente le 11 janvier 2022 ou bien le 1er novembre 2022 ?

Effectivement j'avais pas pensé à ça. Il faut impérativement 8 chiffres.

Bon week-end !

tchi456 · 21 Janvier 2022

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

job75 · 21 Janvier 2022

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+

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

tchi456

XLDnaute Occasionnel

mapomme

XLDnaute Barbatruc

tchi456

XLDnaute Occasionnel

tchi456

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Discussions similaires