Microsoft 365 [VBA] Listes déroulantes à choix multiples sur N colonnes discontinues

[ralph45]

Bonjour ami.e.s XLDien.ne.s,

En fouinant sur ce site , je suis tombé sur un code de liste déroulante à choix multiples (LD_CM) qui me paraissait parfait.
Or, celui-ci ne fonctionne que sur une seule colonne. Comment l'adapter pour qu'il ait un impact sur des colonnes discontinues et avec des validations différentes ?

Dans le fichier exemple joint totalement fictif , j'aurai besoin de gérer 2 LD_CM sur les colonnes B et D.
Ultérieurement, je pourrai générer d'autres LD_CM sur les colonnes I, M, AB (au pif)...

En vous remerciant et à vot' bon coeur. Passez une agréable journée ensoleillée !

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("B2:B11")) 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

 

[ralph45]

Hello XLDien.ne.s,

Après quelques jours très chauds et une bonne douche froide ce matin, je pense que si je modifie le code comme ci-bas, cela pourrait peut-être fonctionner.

Je n'ai pas Excel du week-end, mais si un bonne âme pouvait confirmer ou infirmer...

@peluche

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = True
    On Error GoTo Exitsub
    '1ère colonne
    If Not Intersect(Target, Range("B2:B11")) 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
    '2ème colonne
        If Not Intersect(Target, Range("D2:D11")) 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,
Votre code ajoute/enleve en fonction des choix colonnes B et D

 

[job75]

Bonjour ralph45, Oneida,

Voyez le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sep$, mem$, x$
    If Target.Count > 1 Or Target(1).Text = "" Then Exit Sub
    If [Liste1,Liste2].Find(Target.Text, , xlValues, xlWhole) Is Nothing Then Exit Sub
    sep = ", " 'séparateur
    mem = Target
    Application.EnableEvents = False
    Application.Undo 'annule l'entrée
    x = Replace(Target, sep & mem & sep, sep)
    x = Replace(x, sep & mem, "")
    x = Replace(x, mem & sep, "")
    x = Replace(x, mem, "")
    If x = Target Then x = x & IIf(x = "", "", sep) & mem
    Target = x
    Application.EnableEvents = True
End Sub

Dans la feuille BASE j'utilise des tableaux structurés et les noms définis "Liste1" et "Liste2".

A+

 

[ralph45]

Merci Job75 pour cette simplification du code !