VBA - validation de cellule - undo et intersect

Bonjour,

J'essaie de mettre en place un code pour pallier au fait que la validation par excel (données - validation) peut être écrasée par un simple copier-coller.

Le code est en élaboration, donc je procède par petit bouts mais je bloque sec.

L'idée est de protéger des plages nommées de dates en :

vériifiant s'il y a une intersection entre les cellules modifié et les plages à protéger (une union de plages).

SI c'est le cas, on teste si l'union entre les plages modifiées et les plages à protéger renvoie un Range de plus d'une cellule.

Si c'est le cas on annule la dernière modification utilisateur et on sort.

Ensuite on teste si la valeur de la cellule modifiée n'est pas une date.

Si c'est le cas on annule la dernière modification utilisateur et on sort.

C'est dans ce cas que la procédure plante ==> au niveau du Application.Undo avec un sybillin "la méthode a échouée".

J'essaie pour tester ce code de coller par exemple du texte sur une des colonnes de dates en question.

Parfois, et c'est ce qui est le plus bizarre, la procédure fonctionne une fois (jamais plus d'une) et des fois ça plante tout de suite.

A noter que je remets toujours les Application.EnableEvents à True car l'arrêt au niveau du Application.Undo le laisse à False

J'ai retourné ça dans tous les sens et fait des dizaines de tests mais rien à faire.

SI vous avez une idée, ça me rendrait bien service.

Voici le code fautif :

Private Sub Worksheet_Change(ByVal Target As Range) 'Target ==> plage des cellules modifiées
    Dim rgDteDeb As Range, rgDtefin As Range, rgDteOuvEff As Range, rgDteClot As Range, rgDteSynth As Range
    Dim Isec As Range
    Dim rgDateNonFormule As Range
    'plages de dates
    Set rgDteDeb = Range("dteDeb_questSysoupofoap")
    Set rgDtefin = Range("dteFin_questSysoupofoap")
    Set rgDteOuvEff = Range("dteOuvEff_questSysoupofoap")
    Set rgDteClot = Range("dteClot_questSysoupofoap")
    Set rgDteSynth = Range("dteSynt_questSysoupofoap")
    'union
    Set rgDateNonFormule = Union(rgDteDeb, rgDtefin, rgDteOuvEff, rgDteClot, rgDteSynth)
    Set Isec = Intersect(Target, rgDateNonFormule) 'intersection plage des cellules modifiées et de Union
    MsgBox Isec.Address
    If Not Isec Is Nothing Then 's'il y a une intersection...
        If Isec.Count > 1 Then   '...de plus d'une cellule
            MsgBox "impossible de coller plusieurs dates en même temps"
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
            Exit Sub
        Else 'sinon l'intersection est sur une seule cellule
            If Not IsDate(Isec.Value) Then 'si ce n'est pas une date...
                MsgBox "Ce n'est pas une date"
                Application.EnableEvents = False
                Application.Undo  'annuler la dernière commande
                Application.EnableEvents = True
                Exit Sub
            End If
        End If
    End If
End Sub

Bonsoir,

Après quelques heures de tripatouillage j'ai enfin trouvé une solution.

Je poste le code si ça peut aider : il donc s'agit de prévenir l'écrasement d'une validation par un malheureux copier/coller :

Private Sub Worksheet_Change(ByVal Target As Range)
   ' Application.EnableEvents = True
       ' MsgBox "dans change" & Target.Address
        Dim rgtar As Range
        For Each rgtar In Target
            If Not IsDate(rgtar.Value) Then
                MsgBox rgtar.Address & " n'est pas une date"
            End If
        Next rgtar
      Dim rg As Range, rg1 As Range, inter As Range
    Set rg = Union(Range("dtePaiement2"), Range("dtePaiement1"))
    Set inter = Intersect(Target, rg)
    If Not inter Is Nothing Then
        If IsDate(inter.Value) Or IsEmpty(inter) Then Exit Sub
'        MsgBox "pas date et adresse intersection = " & inter.Address ' & inter.Value
        Application.EnableEvents = False
        Application.undo
        Application.EnableEvents = True
    End If
End Sub

Dans le même ordre d'idée on peut aussi utiliser la désactivation du coller (mais c'est plus handicapant pour l'utilisateur) en utilisant qq chose comme :

if rangeEnQuestion.validation.type then
Application.cutcopyMode = False
Application.EnableEvents = False
Application.undo
Application.EnableEvents = True
End If