Microsoft 365 Liste déroulante selon critère

FCMLE44 · 21 Décembre 2020

Bonjour

Dans la cellule I2, je souhaite intégrer une liste de choix conditionnelle
Je m'explique :
Lorsqu'en cellule H1, j'ai par exemple XXXX, j'aurais dans ma liste de choix toutes les sociétés de la colonne 1 correspondant à XXXX se trouvant dans la colonne F

Je sais faire les validations de données mais ca, je sèche.

Quelqu'un aurait il une idée ?

Merci

cp4 · 22 Décembre 2020

FCMLE44 à dit:
Si par mégarde je clique sur la cellule B13 de la feuille salariés, j'obtiens une erreur d'exécution 1004.
Que pourrais je rajouter dans ce code pour que le débogage n'ait pas lieu
Merci

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Rng As Range, c As Range, d As Object

   With Sheets("Paramètres")
      Set Rng = .Range("J2:J" & .Range("J" & Rows.Count).End(xlUp).Row)
   End With

   If Target.Address = "$D$4" Then
      Set d = CreateObject("Scripting.Dictionary")
      For Each c In Rng: d(c.Value) = "": Next c
      Target.Validation.Delete
      Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
   End If

   If Target.Address = "$B$13" Then
      Set d =...

JHA · 21 Décembre 2020

Bonjour à tous,

A essayer

Avec Microsoft 365, tu dois certainement pouvoir utiliser la fonction filtre()

JHA

cp4 · 21 Décembre 2020

Bonsoir,

Si j'ai bien compris ta demande. Le code est dans le module de la feuille.

Bonne soirée.

edit: bonsoir JHA

R@chid · 22 Décembre 2020

Bonjour @ tous,
Comme il l'a indiqué notre ami JHA, sous Excel pour Microsoft 365 c'est plus facile et on n'a pas besoin de formule matricielle.
Voir PJ

Cordialement

FCMLE44 · 22 Décembre 2020

cp4 à dit:
Bonsoir,

Si j'ai bien compris ta demande. Le code est dans le module de la feuille.

Bonne soirée.

edit: bonsoir JHA

Bonjour

Je n'ai pas réussi à reproduire sur mon fichier réel
Les données sociétés et RG se trouvent effet sur la feuille parametres
Le listes déroulantes sont sur la feuille salariés

J'ai mis cà dans le la feuille salarié ave les bonnes cellules

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range, c As Range, d As Object

Sheets("Paramètres").Select
Set Rng = Range("J2:J" & Range("D" & Rows.Count).End(xlUp).Row)
'End With

Sheets("salariés").Select
If Target.Address = "$D$4" Then
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In Rng: d(c.Value) = "": Next c
   Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
  End If

If Target.Address = "$b$13" Then
    Set d = CreateObject("Scripting.Dictionary")
    For Each c In Rng
If c.Value = Range("$D$4").Value Then
d(c.Offset(0, -5).Value) = ""
End If

Next c
   Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
  End If
End Sub

Cela ne fonctionne pas
Voici le fichier vide des données personnelles

Auriez vous une idée ?

cp4 · 22 Décembre 2020

FCMLE44 à dit:
Bonjour

Je n'ai pas réussi à reproduire sur mon fichier réel
Les données sociétés et RG se trouvent effet sur la feuille parametres
Le listes déroulantes sont sur la feuille salariés

J'ai mis cà dans le la feuille salarié ave les bonnes cellules

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range, c As Range, d As Object Sheets("Paramètres").Select Set Rng = Range("J2:J" & Range("D" & Rows.Count).End(xlUp).Row) 'End With Sheets("salariés").Select If Target.Address = "$D$4" Then Set d = CreateObject("Scripting.Dictionary") For Each c In Rng: d(c.Value) = "": Next c Target.Validation.Delete Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",") End If If Target.Address = "$b$13" Then Set d = CreateObject("Scripting.Dictionary") For Each c In Rng If c.Value = Range("$D$4").Value Then d(c.Offset(0, -5).Value) = "" End If Next c Target.Validation.Delete Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",") End If End Sub

Cela ne fonctionne pas
Voici le fichier vide des données personnelles

Auriez vous une idée ?

Bonjour,

@FCMLE44 : Les .Select sont à éviter, ils ralentissent le code. Le code est dans le module de la feuille "Salariés" pourquoi mettre Sheets("Salariés").Select?

Code corrigé ci-dessous

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Rng As Range, c As Range, d As Object

   With Sheets("Paramètres")
      Set Rng = .Range("J2:J" & .Range("J" & Rows.Count).End(xlUp).Row)
   End With

   If Target.Address = "$D$4" Then
      Set d = CreateObject("Scripting.Dictionary")
      For Each c In Rng: d(c.Value) = "": Next c
      Target.Validation.Delete
      Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
   End If

   If Target.Address = "$B$13" Then
      Set d = CreateObject("Scripting.Dictionary")
      For Each c In Rng
         ' c est en col J on veut atteindre la société en col D, donc on se déplace à gauche de la colJ (soit -6)
         If c.Value = Range("$D$4").Value Then d(c.Offset(0, -6).Value) = ""
      Next c
      Target.Validation.Delete
      Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
   End If
End Sub

Bonne journée.

FCMLE44 · 22 Décembre 2020

Merci beaucoup

FCMLE44 · 22 Décembre 2020

cp4 à dit:

Bonjour,

@FCMLE44 : Les .Select sont à éviter, ils ralentissent le code. Le code est dans le module de la feuille "Salariés" pourquoi mettre Sheets("Salariés").Select?

Code corrigé ci-dessous

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Rng As Range, c As Range, d As Object

   With Sheets("Paramètres")
      Set Rng = .Range("J2:J" & .Range("J" & Rows.Count).End(xlUp).Row)
   End With

   If Target.Address = "$D$4" Then
      Set d = CreateObject("Scripting.Dictionary")
      For Each c In Rng: d(c.Value) = "": Next c
      Target.Validation.Delete
      Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
   End If

   If Target.Address = "$B$13" Then
      Set d = CreateObject("Scripting.Dictionary")
      For Each c In Rng
         ' c est en col J on veut atteindre la société en col D, donc on se déplace à gauche de la colJ (soit -6)
         If c.Value = Range("$D$4").Value Then d(c.Offset(0, -6).Value) = ""
      Next c
      Target.Validation.Delete
      Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
   End If
End Sub

Bonne journée.

Si par mégarde je clique sur la cellule B13 de la feuille salariés, j'obtiens une erreur d'exécution 1004.
Que pourrais je rajouter dans ce code pour que le débogage n'ait pas lieu
Merci

cp4 · 22 Décembre 2020

FCMLE44 à dit:
Si par mégarde je clique sur la cellule B13 de la feuille salariés, j'obtiens une erreur d'exécution 1004.
Que pourrais je rajouter dans ce code pour que le débogage n'ait pas lieu
Merci

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim Rng As Range, c As Range, d As Object

   With Sheets("Paramètres")
      Set Rng = .Range("J2:J" & .Range("J" & Rows.Count).End(xlUp).Row)
   End With

   If Target.Address = "$D$4" Then
      Set d = CreateObject("Scripting.Dictionary")
      For Each c In Rng: d(c.Value) = "": Next c
      Target.Validation.Delete
      Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
   End If

   If Target.Address = "$B$13" Then
      Set d = CreateObject("Scripting.Dictionary")
      For Each c In Rng
         ' c est en col J on veut atteindre la société en col D, donc on se déplace à gauche de la colJ (soit -6)
         If c.Value = Range("$D$4").Value Then d(c.Offset(0, -6).Value) = ""
      Next c
      If d.Count = 0 Then
         MsgBox "Veuillez sélectionner Nom du RG!", vbokonky + vbCritical, "ECHEC....."
         Exit Sub
      Else
         Target.Validation.Delete
         Target.Validation.Add xlValidateList, Formula1:=Join(d.keys, ",")
      End If
   End If
End Sub

FCMLE44 · 23 Décembre 2020

Bonjour
Merci beaucoup

Microsoft 365 Liste déroulante selon critère

FCMLE44

XLDnaute Impliqué

Pièces jointes

cp4

JHA

XLDnaute Barbatruc

Pièces jointes

cp4

XLDnaute Barbatruc

Pièces jointes

R@chid

XLDnaute Barbatruc

Pièces jointes

FCMLE44

XLDnaute Impliqué

Pièces jointes

cp4

XLDnaute Barbatruc

FCMLE44

XLDnaute Impliqué

FCMLE44

XLDnaute Impliqué

cp4

XLDnaute Barbatruc

FCMLE44

XLDnaute Impliqué

Discussions similaires