Microsoft 365 Listes déroulantes multi-sélections et feuilles protégées.

[selkis]

Bonjour à tous,
Etant totalement novice dans tout ce qui touche aux macro et au VBA, je m'essaye à certaine chose et rencontre souvent pas mal de soucis
Mon soucis actuel :
J'ai trouvé la solution suivante afin de pouvoir créer des listes déroulantes multi-sélections sur Excel.
Une fois ce code appliqué, tout fonctionne parfaitement bien jusqu'au moment où je choisi de protéger ma feuille contre certaines modifications.
En fait j'ai certaines de mes plages de cellule déverrouillées (clic droit, format cellule, protection, verrouillée décoché).
Ensuite je vais dans révision, protéger la feuille, sélectionner les cellules déverrouillées cochée.
Je valide.
Une fois la feuille protégée, je peux accéder à mes listes, mais je ne peux pas faire de sélection multiple; seulement un seul choix.
Quelqu'un connaitrait il une solution autre ou alors faut il modifier le code ci dessous ?
Dans ce dernier cas, que mettre ?
Merci pour vos retours.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Not Intersect(Target, Range("C5")) Is Nothing Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue & ", ") > 0 Then

Target.Value = Replace(Oldvalue, Newvalue & ", ", "")
ElseIf InStr(1, Oldvalue, ", " & Newvalue) > 0 Then

Target.Value = Replace(Oldvalue, ", " & Newvalue, "")
ElseIf InStr(1, Oldvalue, Newvalue) = 0 Then

Target.Value = Oldvalue & ", " & Newvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

 

[Oneida]

Bonjour,

créer des listes déroulantes multi-sélections sur Excel.
Comment?
Votre code les conserne-t-elle?

Pour modifier des feuilles proteger voir ici

Méthode Worksheet.Protect (Excel)

Rubrique de référence sur Office VBA

learn.microsoft.com

 

[selkis]

Bonjour,
oui le code fourni permet de faire de la multi-selection dans des listes déroulantes.

 

[riton00]

Bonjour,

Il serait plus simple de joindre un classeur anonymisé et représentatif à l'appui de vos demandes.

Slts

 

[selkis]

Bonjour,
ci-joint un fichier exemple.
Comme vous pouvez le voir, en cellule J10 et J11, il y a une liste déroulante et dans cette liste nous pouvons faire de la sélection multiple.
En revanche dès lors que je protège ma feuille, je n'ai plus cette possibilité.

 

[riton00]

Bonsoir

En rajoutant ActiveSheet.Unprotect au début et ActiveSheet.Protect à la fin peut-être

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = True
    On Error GoTo Exitsub
    If Not Intersect(Target, Range("J10:J11")) Is Nothing Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else: If Target.Value = "" Then GoTo Exitsub Else
            Application.EnableEvents = False
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue & ", ") > 0 Then
                  
                    Target.Value = Replace(Oldvalue, Newvalue & ", ", "")
                ElseIf InStr(1, Oldvalue, ", " & Newvalue) > 0 Then
                  
                    Target.Value = Replace(Oldvalue, ", " & Newvalue, "")
                ElseIf InStr(1, Oldvalue, Newvalue) = 0 Then
                    
                    Target.Value = Oldvalue & ", " & Newvalue
                End If
            End If
        End If
    End If
    Application.EnableEvents = True
Exitsub:
    Application.EnableEvents = True
    ActiveSheet.Protect
End Sub

Slts

 

[selkis]

Super !
Merci beaucoup pour votre aide, cela fonctionne parfaitement.
Bonne soirée à vous et encore merci.