Microsoft 365 Débloquer une cellule selon un autre en VBA

Roseline

XLDnaute Occasionnel
Bonjour à vous,
J'ai joint un fichier pour que ma demande soit plus claire.
J'ai un "formulaire" qui aura plusieurs menus déroulants différents à différents champs. Nous serons plusieurs usagers à l'utiliser donc pour faciliter l'inscription des données, j'aimerais que si dans un cellule X un choix est fait, que seulement les cellules qui doivent être complétées se débloquent automatiquement dans les autres champs. Ce qui ne doit pas être complété, doit demeurer grisé et protégé pour éviter les erreurs..
Comme je sais qu'on peut tout faire avec Excel, j'ai besoin de votre aide pour m'aider à débuter ce fichier.
Merci encore une fois de votre grande aide et une chance que vous êtes là car vous nous aidez énormément.
Bonne journée :)☃️
 

Pièces jointes

  • Aide excel.xlsm
    16.1 KB · Affichages: 8
Solution
Bonjour Roseline, sylvanu,
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Protect UserInterfaceOnly:=True
[A2:D7].Interior.ColorIndex = 15 'gris
[A2:D7].Locked = True
[B2].Interior.ColorIndex = 6  'jaune
[B2].Locked = False
If [B2] = "Superviseur" Then
    [D2,B3].Interior.ColorIndex = 6  'jaune
    [D2,B3].Locked = False
ElseIf [B2] = "Cadre" Then
    [B5,C6,D5].Interior.ColorIndex = 6 'jaune
    [B5,C6,D5].Locked = False
End If
End Sub
A+

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Roseline,
D'après ce que j'ai compris, un essai en PJ avec :
Pour les autorisations d'écriture :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Fin
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [A2:D7]) Is Nothing Then
        C = Target.Address
        If C = "$B$2" Then Exit Sub
        If [B2] = "Superviseur" And (C = "$D$2" Or C = "$B$3") Then Exit Sub
        If [B2] = "Cadre" And (C = "$B$5" Or C = "$C$6" Or C = "$D$5") Then Exit Sub
        [A1].Select
    End If
Fin:
End Sub
Pour les cellules autorisées :
Code:
Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fin2: If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [B2]) Is Nothing Then
         Application.ScreenUpdating = False
         [A2:D7].Interior.Color = RGB(200, 200, 200)
         If Target = "Superviseur" Then
            Range("B2,B3,D2").Interior.Color = vbWhite
         ElseIf Target = "Cadre" Then
            Range("B2,B5,C6,D5").Interior.Color = vbWhite
         End If
    End If
Fin2:
Application.ScreenUpdating = True
End Sub
J'ai interdit les écritures en repositionnant le curseur en A1.
 

Pièces jointes

  • Aide excel (2).xlsm
    22.7 KB · Affichages: 2

job75

XLDnaute Barbatruc
Bonjour Roseline, sylvanu,
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Protect UserInterfaceOnly:=True
[A2:D7].Interior.ColorIndex = 15 'gris
[A2:D7].Locked = True
[B2].Interior.ColorIndex = 6  'jaune
[B2].Locked = False
If [B2] = "Superviseur" Then
    [D2,B3].Interior.ColorIndex = 6  'jaune
    [D2,B3].Locked = False
ElseIf [B2] = "Cadre" Then
    [B5,C6,D5].Interior.ColorIndex = 6 'jaune
    [B5,C6,D5].Locked = False
End If
End Sub
A+
 

Pièces jointes

  • Aide excel.xlsm
    22.9 KB · Affichages: 7

Roseline

XLDnaute Occasionnel
Bonjour Roseline, sylvanu,
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Protect UserInterfaceOnly:=True
[A2:D7].Interior.ColorIndex = 15 'gris
[A2:D7].Locked = True
[B2].Interior.ColorIndex = 6  'jaune
[B2].Locked = False
If [B2] = "Superviseur" Then
    [D2,B3].Interior.ColorIndex = 6  'jaune
    [D2,B3].Locked = False
ElseIf [B2] = "Cadre" Then
    [B5,C6,D5].Interior.ColorIndex = 6 'jaune
    [B5,C6,D5].Locked = False
End If
End Sub
A+
Bonjour job75,
Merci pour ta réponse et j'aime beaucoup la solution que tu m'as proposé et c'est en plein ce que je cherchais. C'est simple et rapide et j'ai été capable d'adapter le tout à mon fichier. J'ai une interrogation par contre, si j'ai deux cellules fusionnées, le code bloque. Par exemple, si je fusionne les cellules C8 et D8. As-tu une idée. Merci beaucoup beaucoup de ton aide.
Bonne journée
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
315 127
Messages
2 116 534
Membres
112 771
dernier inscrit
mikadu49