Choix multiples pour une valeur identique

[activeforce]

Bonjour,

Quel formule dois je utiliser pour avoir un choix multiple pour une valeur identique.

Exemple selon le tableau ci joint : Dans la cellule A3 , je choisis la famille BR, j'aimerai qu'automatiquement, il me propose les différents types selon la matrice. Ici dans notre exemple BR correspond à Bouche de reprise ou Bouche d'extraction ou Grille de transfert.

Merci par avance.

 

[Robert]

Re : Choix multiples pour une valeur identique

Bonsoir la force, bonsoir le forum,

En pièce jointe une proposition avec le code ci-dessous :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim lt As String 'déclare la variable lt (LisTe de validation)

'si le changement a lieu aillerus que dans la colonne A ou sur les lignes 1 à 2, sort de la procédure
If Target.Column > 1 Or Target.Row < 3 Then Exit Sub
'si la cellule est effacée, efface la cellule en colonne B, sort de la procédure
If Target.Value = "" Then Target.Offset(0, 1).Value = "": Exit Sub
With Sheets("Matrices") 'prend en compte l'onglet "Matrices"
    dl = .Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée de la colonne 2 (=B)
    Set pl = .Range("B3:B" & dl) 'définit la plage pl
End With 'fin de la prise en compte de l'onglet "Matrices"
For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl
    If cel.Value = Target.Value Then 'condition : si la valeur de la cellule est égale à celle de la cellule éditée
        lt = IIf(lt = "", cel.Offset(0, 1).Value, lt & "," & cel.Offset(0, 1).Value) 'définit la liste lt
    End If 'fin de la condition
Next cel 'prochaine cellule de la boucle
With Target.Offset(0, 1).Validation 'prend en compte la validadion de données dans la cellule adjacente en colonne B
    .Delete 'supprime une éventuelle validation de données existante
    .Add Type:=xlValidateList, Formula1:=lt 'ajoute la liste lt comme nouvelle validation de données
End With 'fin de la prose en compte de la validation de données...
'si la liste lt n'est pas vide, affiche le premier élément dans la cellule adjacente en colonne B
If lt <> "" Then Target.Offset(0, 1).Value = Split(lt, ",")(0)
End Sub

Le fichier :

 

[BOISGONTIER]

Re : Choix multiples pour une valeur identique

Bonjour,

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([a3:A1000], Target) Is Nothing And Target.Count = 1 Then
    Set f = Sheets("matrices")
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In f.Range("b3:b" & f.[b65000].End(xlUp).Row): d(c.Value) = "": Next c
    Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([a3:A1000], Target) Is Nothing And Target.Count = 1 Then
   If Target <> "" Then
    Set f = Sheets("matrices")
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In f.Range("b3:b" & f.[b65000].End(xlUp).Row)
      If c.Value = Target Then d(c.Offset(, 1)) = ""
    Next c
    Target.Offset(, 1).Validation.Delete
    Target.Offset(, 1).Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
    a = d.keys: Target.Offset(, 1) = a(0)
    If d.Count > 1 Then Target.Offset(, 1).Select: SendKeys "%{down}"
   Else
    Target.Offset(, 1) = ""
   End If
  End If
End Sub

Attention! sur Excel 2000, la longueur de la chaîne de données/validation doit être <200 caractères


JB

 

[activeforce]

Re : Choix multiples pour une valeur identique

Merci Robert et Boisgontier.
Bonne journée à vous.

 

[Dugenou]

Re : Choix multiples pour une valeur identique

Bonjour à tous,
mes respects aux macroteurs
Une solution avec formules et un petit bout de macro pour générer la liste de validation.
Cordialement

 

[activeforce]

Re : Choix multiples pour une valeur identique

Je viens de rajouter une colonne , j'ai essayer de modifier la macro en conséquence et je n'ai pas trouver la solution.
Pouvez vous à nouveau m'aider svp.

 

[Robert]

Re : Choix multiples pour une valeur identique

Bonjour le fil, bonjour le forum,

Le code de Jacques adapté à ton cas :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect([a3:a1000], Target) Is Nothing And Target.Count = 1 Then
    Set f = Sheets("matrices")
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In f.Range("b3:b" & f.[b65000].End(xlUp).Row): d(c.Value) = "": Next c
    Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([a3:a1000], Target) Is Nothing And Target.Count = 1 Then
   If Target <> "" Then
    Set f = Sheets("matrices")
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In f.Range("b3:b" & f.[b65000].End(xlUp).Row)
      If c.Value = Target Then d(c.Offset(, 1)) = ""
    Next c
    Target.Offset(, 2).Validation.Delete
    Target.Offset(, 2).Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
    a = d.keys: Target.Offset(, 2) = a(0)
    If d.Count > 1 Then Target.Offset(, 2).Select: SendKeys "%{down}"
   Else
    Target.Offset(, 2) = ""
   End If
  End If
End Sub

 

[activeforce]

Re : Choix multiples pour une valeur identique

Encore merci pour votre disponibilité.