Intersect fait bizarre

Bonjour Tout le monde.

Je suis aussi coincée dans un projet.

J'ai une feuille bdd comme sur l'image

Je souhaite que :

- Si l'utilisateur clique sur une cellule remplie, couleur violet-foncée,

La valeur de la cellule reste inchangée.

• Si le clic est dans une Cellule Verte, il peut la modifier
• Ailleurs il n'a aucun droit.

Dim AncienneValeur As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A2:A5,D2:F2,H2:K2")) Is Nothing Then
    Target = AncienneValeur
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A5,D2:F2,H2:K2")) Is Nothing Then
       AncienneValeur = Target.Value
    End If
End Sub

Mais il y a aussi des fois où il ne fonctionne pas du tout.

Quelqu'un peut-il m'aider ou m'orienter ?

Merci Beaucoup pour le temps que vous allez accorder à ce problème !

Bonsoir,

voyez ce que je vous propose :

@ bientôt

LouReeD

Salut Nathalie,

Salut Lou Reed,

- très simple : un clic dans une cellule de couleur différente que celle autorisée envoie (SELECT) vers [B2] ;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
If Target.Interior.ColorIndex <> 43 Then [B2].Select
'
End Sub

- sinon, tu te choisis (par exemple, n'est-ce pas) une cellule "secrète" où un clic ou un double-clic ou un clic-droit ou l'encodage d'un symbole particulier, ou..., ou... déclenchera la protection ou la libération des cellules concernées, voire de la feuille complète.

L'imagination au pouvoir!

- ici, j'ai choisi un double-clic en [A1] pour autoriser ou refuser l'accès à [A1:E2] et un double-clic en [A2] pour libérer la feuille.

La couleur de fonte de [B1] passe du rouge au blanc selon la situation mais tu peux inventer mille autres trucs...

Tu peux choisir de ne pas mettre de mot de passe en supprimant Password:="123" du code.

Mot de passe sophistiqué exigé, hein : 123... Trouveront jamais!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Cancel = True
'
If Not Intersect(Target, [A1]) Is Nothing Then
    Sheets("Feuil1").Unprotect
    [B1].Font.ColorIndex = IIf([B1].Font.ColorIndex = 2, 3, 2)
    Range("A1").Resize(2, 5).Locked = IIf([B1].Font.ColorIndex = 3, True, False)
    Sheets("Feuil1").Protect Password:="123"
End If
'
If Not Intersect(Target, [A2]) Is Nothing Then Sheets("Feuil1").Unprotect
'
End Sub

A+

Bonjour

curulis57

LouReeD

J'apprécie vos efforts, mais j'arrive pas à implémenter sur mon fichier car cela ne marche pas toujours.

J'opterai bien pour un UNDO si l'utilisateur clique sur une cellule blanche ou une entete... Je suis nulle, cela me ménace, j'arrive pas à comprendre et pourtant je griffonne des trucs qui marchent, puis ne marchent plus ...etc.

Je vous soumets mon fichier que vous puissiez y agir directement, mille merci une fois de plus.

Bonjour,

Il te suffit simplement de lui interdire la sélection en sélectionnant la cellule d'à coté ou de dessous :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Application.EnableEvents = False

    If Not Intersect(Target, Range("A2:A5")) Is Nothing Then Target.Offset(, 1).Select
    If Not Intersect(Target, Range("D2:F2,H2:K2")) Is Nothing Then Target.Offset(1).Select

    Application.EnableEvents = True

End Sub

Merci à tous !

Surtout à toi Theze

J'ai griffonné un truc que j'ai rajouté au code de Thèze et qui marche ...

J'ai utilisé l'enregistreur des macros pour sélectionner le restant des plages... puis j'ai rajouté une troisième ligne à ton code Theze. Puis sachant que le reste des lignes vides à restreindre est énorme, j'ai dû masquer le reste et définir une ScrollArea.

voici ce que cela donne au finish :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Application.EnableEvents = False

    If Not Intersect(Target, Range("A2:A5")) Is Nothing Then Target.Offset(, 1).Select
    If Not Intersect(Target, Range("D2:F2,H2:K2")) Is Nothing Then Target.Offset(1).Select
    If Not Intersect(Target, Range("A1:L1,C1:C31,G1:G31,I1:I31,A6:C31,D13:G31,L1:L31,J4:K31,A30:L31")) Is Nothing Then _
    CreateObject("Wscript.shell").popup "Opération impossible !", 1, "iStock Manager": [B2].Select
        'CreateObject("Wscript.shell").popup "Il y a 02 lignes vides, vous ne pouvez insérer davantage sans les remplir!", 1,
    Application.EnableEvents = True

End Sub

Problème résolu, Merci encore !

Content de t'avoir aidé