Incrémentation de l'heure + Problème actualisation

Bonjour la team ! Toujours aussi novice en vba, je voudrais mettre en place l'incrémentation de l'heure lorsque j'étire la date dans la colonne T

Pour être précis, en T si j'insère la date dans une case, l'heure actuelle s'affiche dans la même ligne sur la colonne X. J'aimerais du coup quand j'étire la date (sans incrémentation), que l'heure fasse la même chose. Mais actuellement j'ai juste réussi avec l'aide d'un membre à mettre la date :

Voici le code qu'il y a :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Teste si on double-clique dans la zone spécifié
If Not Application.Intersect(Target, Range("S2:S99999")) Is Nothing Then

'Si la cellule est vide on y inscrit le chiffre correxpondant à sa couleur
If Target = "" Then

ActiveCell.Value = Format(Now(), "mm/dd/yyyy")
End If
End If

'Teste si on double-clique dans la zone spécifié
If Not Application.Intersect(Target, Range("T2:T99999")) Is Nothing Then

'Si la cellule est vide on y inscrit le chiffre correxpondant à sa couleur
If Target = "" Then

ActiveCell.Value = Format(Now(), "mm/dd/yyyy")

X = ActiveCell.Address
Y = Right(X, 2)
Z = "X"
a = "X" & Y
Range(a).Select
ActiveCell.Value = Format(Now(), "hh:mm")
End If
End If

'HEURE
If Not Application.Intersect(Target, Range("X2:X99999")) Is Nothing Then

'Si la cellule est vide on y inscrit le chiffre correxpondant à sa couleur
If Target = "" Then

ActiveCell.Value = Format(Now(), "hh:mm")

End If
End If

X = ActiveCell.Address
Y = Right(X, 2)
Z = "U"
a = "U" & Y
B = Range(a).Select
nb_cara = Len(Range(a))
If nb_cara = 4 Then
a = "T" & Y
B = Range(a)
D = "O" & Y
E = Range(D)
F = B - E
If F > 0 Then

MsgBox "ATTENTION DATE DE RESPECT NE PEUT PAS ETRE égale à OUI "
ActiveCell.Value = ""
End If
If F = 0 Then
a = "X" & Y
B = Range(a)
D = "P" & Y
E = Range(D)
F = B - E
If F > 0.208 Then

MsgBox "ATTENTION DATE DE RESPECT NE PEUT PAS ETRE égale à OUI "
ActiveCell.Value = ""
End If

End If
End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
' Inscrire automatiquement les modification de T dans X
If Not Application.Intersect(Target, Range("T2:T99999")) Is Nothing Then
Application.EnableEvents = False
For Each Cel In Target
Range("X" & Cel.Row).Value = Range("T" & Cel.Row).Value
Next Cel
Application.EnableEvents = True
End If

X = ActiveCell.Address
YA = Right(X, 2)
a = "U" & YA

B = Range(a)
If Range(X) <> "" Then
If B <> "" Then

If Target.Address = Target.Address Then

Worksheet_BeforeDoubleClick ByVal Target, True

End If
End If
End If

X = ActiveCell.Address
If Range(X) = "" Then
Y = Left(X, 2)

If Y = "$T" Then

Y = Left(Right(X, 2), 2)
Z = "X"
a = "X" & Y - 1
Range(a).Select
If YA = Y Then

ActiveCell.Value = Format(Now(), "hh:mm")
End If
End If
End If

End Sub

Sub Compareur()

X = ActiveCell.Address
Y = Right(X, 2)
Z = "U"
a = "U" & Y
B = Range(a).Select
nb_cara = Len(Range(a))
If nb_cara = 4 Then
a = "T" & Y
B = Range(a)
D = "O" & Y
E = Range(D)
F = B - E
If F > 0 Then
MsgBox "ATTENTION DATE DE RESPECT NE PEUT PAS ETRE égale à OUI "
ActiveCell.Value = ""
End If
If F = 0 Then
a = "X" & Y
B = Range(a)
D = "P" & Y
E = Range(D)
F = B - E
If F > 0.208 Then
MsgBox "ATTENTION DATE DE RESPECT NE PEUT PAS ETRE égale à OUI "
ActiveCell.Value = ""
End If

End If
End If

End Sub

Une petite chose aussi, j'ai remarqué quand je supprime la date, ca retire donc l'heure qu'il y a en face, mais ca remet l'heure actuelle sur la ligne du dessus comme sur le screen ci dessus !

Je vous souhaite une bonne journée et un bon réveil ;)

A++

PS : Je m'excuse auprès des modos pour le code sous ce format là mais je n'arrive aps à le mettre avec <> :)

Bonjour

Je m'excuse auprès des modos pour le code sous ce format là mais je n'arrive aps à le mettre avec <> :)

Il suffit de cliquer sur l'icone </> et de coller votre code dans la fenêtre puis choisir "Insérer". je le corrige pour vous.

Je ne comprends pas trop l'utilité de certaines lignes de code que vous avez placées mais pour répondre à votre question, essayez en remplaçant votre code par celui-ci dessous

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range
' Inscrire automatiquement les modification de T dans X
If Not Application.Intersect(Target, Range("T2:T" & Range("T" & Rows.Count).End(xlUp).Row)) Is Nothing Then
Application.EnableEvents = False
For Each cel In Selection
    Range("X" & cel.Row).Value = Format(Now, "hh:mm:ss")
Next cel
Application.EnableEvents = True
End If
End sub

Dans la mesure du possible j'éviterais l'instruction Application.enableEvents au profit d'une autre manière de faire mais à voir après peut être.

Cordialement

Salut @Dan,

Je te remercie infiniment pour ton aide ! Merci et bravo ;) Ca marche bien ! Sauf que maintenant quand je supprime la date, ca ne supprime pas l'heure, (avant ca marchait ?)
Après j'ai juste supprimé les secondes dans le format car elle ne me sont pas utiles dans mon cas ;)

Mais quand j'étire parfois les secondes apparaissent comme cela

Concernant le problème que j'ai cité plus haut, aurais-tu une solution ?

Les dates sont supprimées une à une ? ou en lot aussi ?

Concernant le problème que j'ai cité plus haut, aurais-tu une solution ?

Concernant la suppression de l'heure qui se remet en ligne au dessus ?

@Dan

Alors pour la suppression ca peut etre les deux, du genre si je prends qu'une date ca supprime l'heure sur la ligne ou alors en lot ca supprime les heures du lot tu vois ce que je veux dire ?

Et oui tout à fait c'est concernant l'heure qui se remet au dessus

Dans votre feuille (tout en haut), quelle est la première ligne de code que vous avez ?

Voici les toutes premiers lignes du codes

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Je voulais juste une seule et la première ....
Pour être sûr, vous pouvez modifier le post ?

Chose faite c'est bon comme ca ?

Ok. parfait.
Juste au dessus cette ligne Private Sub Worksheet_BeforeDoubleClick, collez le code complet ci-dessous

Dim stpevt As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range

If stpevt = True Then Exit Sub

dlg = Selection.Rows.Count + Target.Row - 1
If Not Application.Intersect(Target, Range("T2:T" & dlg)) Is Nothing Then

    For Each cel In Selection
        stpevt = True
        Select Case cel
            Case Is <> ""
                With Range("X" & cel.Row)
                    .Value = Format(Now, "hh:mm")
                    .NumberFormat = "hh:mm"
                End With
            Case Is = ""
                Range("X" & cel.Row).ClearContents
        End Select
    Next cel
End If
stpevt = False
End Sub

Refaites un essai

@Dan

Ce message est apparue en exécutant le code

J'ai retiré le End Sub mais cela faisait pareil

Ce message est apparue en exécutant le code

Je m'en doutais.

Je vous ai demandé quel était la première ligne de code dans la feuille et vous m'avez écrit "Private sub ...double click
Ce qui n'est pas juste donc la question reste --> quelle est la première ligne de code que vous avez

@Dan

Moi la toute première ligne que j'ai écris dans le fichier c'est bien :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Qui me permet de faire double clic donc pour afficher soit l'heure ou la date dans la colonne X ou T

Mais autant pour moi je ne l'avais pas collé au bon endroit car j'ai mal lu votre message. je m'en excuse ...

DOnc j'ai refais la manipulation et j'ai quand même le même message d'erreur quand je fais double clic sur la cellule !

PS : Mais quand je supprime la date en revanche ca supprime bien l'heure et ca me met plus l'heure en plus au dessus ! Super

je précise que j'ai neutralisé avec les ' le ptit bout de code que tu m'avais dit de mettre avant quelques messages plus hauts

La variable Dim stpevt as boolean doit absolument être en première ligne sans quoi vous aurez une erreur d'exécution

Si vous avez une erreur c'est uniquement dû aux autres codes dans votre feuille. Vous avez probablement deux End Sub au lieu d'un seul

Pour vos tests supprimez ou désactivez tous les autres codes de la feuille

J'ai essayé de les supprimer mais j'ai sans cesse une erreur
Puis je vous envoyer le fichier en MP ?

Puis je vous envoyer le fichier en MP ?

Oui soit vous le mettez ici sans données confidentielles

je l'envoie en MP

1. En dessous du END SUB de votre macro doubleclick vous avez les lignes jusque juste avant la ligne SUB comparateur(). Il faut les désactiver. elles ne font pas partie d'une macro

X = ActiveCell.Address
YA = Right(X, 2)
a = "U" & YA

B = Range(a)
....
.....
....
End sub

2. en dessous de Private Sub Worksheet_Change - ligne 2 dans votre feuille, vous avez un END SUB. Pourquoi ???
Si vous recopiez mal ce que je donne, vous n'allez jamais y arriver

3. cette macro --> Private Sub Worksheet_Change10(ByVal Target As Range) est incorrecte et ne peut fonctionner. Vous devez la supprimer.

Il y a vraiment pas mal de choses à revoir dans votre fichier là...

Dan,

Si je désactive les lignes que tu m'as dit, je n'arrive plus du tout à insérer la date.

quand je fais double clic rien ne se passe

Je suis désolé mais c'est un fichier que j'ai récupéré et que je dois retravailler. Il n'est pas simple de comprendre dans mon contexte helas
Et j'ai souvent du mal à voir la logique du code

Si je désactive les lignes que tu m'as dit, je n'arrive plus du tout à insérer la date.

Absolument pas. Vous lisez mal ce que je vous écrit au point 1 et désactivez au mauvais endroit. La partie dont je parle ne concerne pas la macro double click

Je me répète. Juste après le END SUB, vous la ligne X = Activecell.adress.
Vous devez supprimer cette ligne et toutes les lignes en dessous jusque la ligne avant SUB Comparateur

Cordialement