XL 2019 Compiler plusieurs Private Sub Worksheet_Change

macgillian · 10 Décembre 2021

Bonjour à tous,

Je connais un peu EXCEL mais même si j'ai pas mal de notions en matière de formule je ne connais rien aux macros...
Mon problème : j'ai des listes déroulantes dans une feuille que je souhaite protéger des copier-coller qui viennent écraser la validation de données..
Toutefois je ne souhaite pas interdire le copier coller, juste l'autoriser dans la limite des valeurs définies dans la liste source...
En cherchant ici j'ai trouvé un code qui a marché :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("F7:F3488")) Is Nothing Then Exit Sub
If Range("AZ7:AZ712").Find(Target.Value, , xlValues, xlWhole) Is Nothing Then Target.Value = ""
End Sub

Ceci fonctionne parfaitement (je ne peux copier coller dans la colonne F que les valeurs renseignées en colonne AZ....)
En cas de copier coller d'une autre valeur la cellule cible redevient blanche.
Ma question : j'aimerais appliquer ce procédé dans la même feuille à plusieurs colonnes dans le tableau (par exemple en colonne D je veux limiter le copier coller aux valeurs situées en colonne BD...
J'ai essayé de bricoler un code comme ça :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("F7:F3488")) Is Nothing Then Exit Sub
If Range("AZ7:AZ712").Find(Target.Value, , xlValues, xlWhole) Is Nothing Then Target.Value = ""
If Application.Intersect(Target, Range("D7:D3488")) Is Nothing Then Exit Sub
If Range("BD7:BD334").Find(Target.Value, , xlValues, xlWhole) Is Nothing Then Target.Value = ""
End Sub

Bien sûr ça ne fonctionne pas...
N'étant pas connaisseur, quelque chose m'échappe.
Pourriez vous m'éclairer ?
merci d'avance

Macgillian

Hasco · 15 Décembre 2021

Bonjour,

Comme votre demande est complexe et que vous vous dites novice en vba, je vous propose une simple mise en forme conditionnelle dans le fichier ci-joint plutôt que de vous pondre un code que vous ne saurez pas adapter.

Formule MFC : =ESTNA(EQUIV(D3;L$3:L$10;0))
Appliquée à : $D$3:$F$30

Cordialement

Hasco · 10 Décembre 2021

Bonjour,

Non testé puisqu'il n'y a pas de fichier joint (mais ça devrait le faire) :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
    '
    ' Tester si l'on est dans la bonne plage
    If Not Application.Intersect(Target, Range("F7:F3488")) Is Nothing Then
        If Range("AZ7:AZ712").Find(Target.Value, , xlValues, xlWhole) Is Nothing Then Target.Value = ""
    ElseIf Not Application.Intersect(Target, Range("D7:D3488")) Is Nothing Then
        If Range("BD7:BD334").Find(Target.Value, , xlValues, xlWhole) Is Nothing Then Target.Value = ""
    End If
End Sub

cordialement

Dranreb · 10 Décembre 2021

Bonjour.
L'Exit Sub ne convient que s'il n'y a qu'un cas à traiter, en abandonnant la procédure si on n'est pas dans ce cas là. Lorsqu'il y a plusieurs cas il faut des If … Then … ElseIf … Then … End If ou une structure Select Case True

macgillian · 10 Décembre 2021

Un grand merci à vous 2 ça fonctionne je vais faire évoluer le code pour toutes mes colonnes concernées, j'y vois un peu plus clair !

job75 · 10 Décembre 2021

Bonjour macgillian, bienvenue sur XLD,

macgillian à dit:
Mon problème : j'ai des listes déroulantes dans une feuille que je souhaite protéger des copier-coller qui viennent écraser la validation de données..

C'est un problème intéressant mais plus compliqué que ce que vous croyez, testez ce code :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, d As Object, v As Validation
Set P = [D7:D3488,F7:F3488] 'plages à adapter
Set P = Intersect(Target, P)
If P Is Nothing Then Exit Sub
On Error Resume Next
'---tableau des formules de validation---
Set d = CreateObject("Scripting.Dictionary")
For Each Target In P
    Set v = Target.Validation
    If IsError(v.Type) Then Else If v.Type = xlValidateList Then d(Target.Address) = v.Formula1
Next Target
'---vérification---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Application.Undo 'annule les modifications
For Each Target In P
    Set v = Target.Validation
    If IsError(v.Type) Then Else If v.Type = xlValidateList Then If d(Target.Address) <> v.Formula1 Then GoTo 1
Next Target
Application.Undo 'rétablit les modifications
1 Application.EnableEvents = True 'réactive les évènements
End Sub

A+

macgillian · 10 Décembre 2021

job75 à dit:

Bonjour macgillian, bienvenue sur XLD,

C'est un problème intéressant mais plus compliqué que ce que vous croyez, testez ce code :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, d As Object, v As Validation
Set P = [D7:D3488,F7:F3488] 'plages à adapter
Set P = Intersect(Target, P)
If P Is Nothing Then Exit Sub
On Error Resume Next
'---tableau des formules de validation---
Set d = CreateObject("Scripting.Dictionary")
For Each Target In P
    Set v = Target.Validation
    If IsError(v.Type) Then Else If v.Type = xlValidateList Then d(Target.Address) = v.Formula1
Next Target
'---vérification---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Application.Undo 'annule les modifications
For Each Target In P
    Set v = Target.Validation
    If IsError(v.Type) Then Else If v.Type = xlValidateList Then If d(Target.Address) <> v.Formula1 Then GoTo 1
Next Target
Application.Undo 'rétablit les modifications
1 Application.EnableEvents = True 'réactive les évènements
End Sub

A+

Merci je vais essayer

macgillian · 10 Décembre 2021

job75 à dit:

Bonjour macgillian, bienvenue sur XLD,

C'est un problème intéressant mais plus compliqué que ce que vous croyez, testez ce code :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, d As Object, v As Validation
Set P = [D7:D3488,F7:F3488] 'plages à adapter
Set P = Intersect(Target, P)
If P Is Nothing Then Exit Sub
On Error Resume Next
'---tableau des formules de validation---
Set d = CreateObject("Scripting.Dictionary")
For Each Target In P
    Set v = Target.Validation
    If IsError(v.Type) Then Else If v.Type = xlValidateList Then d(Target.Address) = v.Formula1
Next Target
'---vérification---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Application.Undo 'annule les modifications
For Each Target In P
    Set v = Target.Validation
    If IsError(v.Type) Then Else If v.Type = xlValidateList Then If d(Target.Address) <> v.Formula1 Then GoTo 1
Next Target
Application.Undo 'rétablit les modifications
1 Application.EnableEvents = True 'réactive les évènements
End Sub

A+

Merci je vais essayer

macgillian · 15 Décembre 2021

@job75 : ne connaissant pas visual basic je n'arrive pas à exploiter ce code, je suis trop novice, je n'ai pas les bases...
@Hasco : je n'ai pas réussi à ajouter une 3 ème condition j'ai fait un fichier test (ci joint) mais j'ai une erreur lors de l'exécution....j'ai du foiré quelque part

Hasco · 15 Décembre 2021

Bonjour,

Comme votre demande est complexe et que vous vous dites novice en vba, je vous propose une simple mise en forme conditionnelle dans le fichier ci-joint plutôt que de vous pondre un code que vous ne saurez pas adapter.

Formule MFC : =ESTNA(EQUIV(D3;L$3:L$10;0))
Appliquée à : $D$3:$F$30

Cordialement

macgillian · 16 Décembre 2021

Un grand merci
ça fonctionne et j'arrive au résultat que je souhaitais (tout en comprenant ce que je fais)

XL 2019 Compiler plusieurs Private Sub Worksheet_Change

macgillian

XLDnaute Nouveau

Hasco

Hasco

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

macgillian

XLDnaute Nouveau

job75

XLDnaute Barbatruc

macgillian

XLDnaute Nouveau

macgillian

XLDnaute Nouveau

macgillian

XLDnaute Nouveau

Pièces jointes

Hasco

XLDnaute Barbatruc

Pièces jointes

macgillian

XLDnaute Nouveau

Discussions similaires