XL 2019 Compiler plusieurs Private Sub Worksheet_Change

macgillian

XLDnaute Nouveau
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
 
Solution
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

XLDnaute Barbatruc
Repose en paix
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
 

job75

XLDnaute Barbatruc
Bonjour macgillian, bienvenue sur XLD,
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

XLDnaute Nouveau
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

XLDnaute Nouveau
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

XLDnaute Nouveau
@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
 

Pièces jointes

  • EXEMPLE.xlsm
    15.9 KB · Affichages: 6
  • Erreur.JPG
    Erreur.JPG
    17.5 KB · Affichages: 20

Hasco

XLDnaute Barbatruc
Repose en paix
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
 

Pièces jointes

  • macgillian.xlsm
    16.7 KB · Affichages: 12
Dernière édition:

Discussions similaires

Réponses
1
Affichages
204

Statistiques des forums

Discussions
311 720
Messages
2 081 915
Membres
101 838
dernier inscrit
Christelle.B86