Macro à compléter double-clic

[un internaute]

Bonjour le forum,
J'ai la macro ci-dessous:

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 1 Then Target.Value = Date: Cancel = True
If Not Intersect(Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
If Not IsError(Application.Match(CSng(Date), Columns("A"), 0)) Then
MsgBox "Une séance existe déjà à cette date"
Target = ""
End If
Cancel = True
ElseIf Not Intersect(Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
End If
End Sub

Lorsque je double - clic sur cellule A3 ça me met "Une séance existe déjà à cette date" alors que c'est la première d'une série et que je fait OK ça me l'efface.
Par contre si je tape par exemple 29/10/2016 ça me met bien la date ezt ça la garde
Si je double clic sur cellule A4 ça me met bien : "Une séance existe déjà à cette date" ce que je veux
Y a t-il un moyen pour remédier au premier Double clic et que ça garde la date?
D'avance merci pour vos éventuels retours
Bon WE à tous

 

[M12]

Bonjour,
Teste comme ceci

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column = 1 And Target.Value <> "" Then
        MsgBox "Une séance existe déjà à cette date"
        Exit Sub
    Else
        If Target.Column = 1 Then Target.Value = Date: Cancel = True
            If Not Intersect(Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
                If Not IsError(Application.Match(CSng(Date), Columns("A"), 0)) Then
                    MsgBox "Une séance existe déjà à cette date"
                    Target = ""
                End If
                Cancel = True
            ElseIf Not Intersect(Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row), Target) Is Nothing Then
        End If
    End If
End Sub

 

[un internaute]

Bonjour M12
Même résultat
Merci de t'intéresser au problème.
Cordialement

 

[M12]

Dans ce cas, enlève ton TARGET="" après ton msgbox

 

[un internaute]

Dans ce cas, enlève ton TARGET="" après ton msgbox

Effectivement ça le garde bien mais lorsque je clique sur la cellule A4 ça met bien
"Une séance existe déjà à cette date" mais la date reste donc 2 fois la même date.
Merci encore on progresse un peu.
Cordialement

 

[M12]

Oui, mais je ne comprend pas trop bien ce que tu veux comme date inscrite ??

 

[un internaute]

Lorsque je Double clique sur la cellule A3 ça m'affiche
samedi 29 octobre 2016
Quelques fois si je suis "distrait" je clique une deuxième fois sur la cellule suivante A4 et ça m'affiche à nouveau => samedi 29 octobre 2016
Je suis "obligé" de faire suppr (pas le problème) ou alors je ne m'en aperçoit pas et j'ai 2 fois la même date.
Cordialement

 

[Paf]

Bonjour à tous,

la solution parait de vérifier si la date existe déjà avant de l'inscrire !

a priori

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row + 1), Target) Is Nothing Then
    If Not IsError(Application.Match(CSng(Date), Columns("A"), 0)) Then
        MsgBox "Une séance existe déjà à cette date"
        Target = ""
    Else
        Target.Value = Date
    End If
    Cancel = True
End If
End Sub

A+

 

[un internaute]

Bonjour à tous,

la solution parait de vérifier si la date existe déjà avant de l'inscrire !

a priori

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row + 1), Target) Is Nothing Then
    If Not IsError(Application.Match(CSng(Date), Columns("A"), 0)) Then
        MsgBox "Une séance existe déjà à cette date"
        Target = ""
    Else
        Target.Value = Date
    End If
    Cancel = True
End If
End Sub

A+

 

[un internaute]

Bonjour Paf,
Eh! oui bien vu
Chapeau "l'artiste".
je te remercie et te souhaite un bon WE
Bien cordialement