XL 2010 Liste déroulante cascade pour affiner recherche

Fastier

XLDnaute Nouveau
Bonjour à toutes et à tous !

Ici ma première question sur le forum.

J’essaie de développer un outil pour le restaurant pour lequel je travail à partir duquel on pourrait remplir des fiche techniques utilisant une liste de produit fournisseur.

Je m'explique il y aurait sur la page "produit" un tableau incluant: colonne A la catégorie du produit (viande, poisson...), colonne B le fournisseur, enfin colonne C le produit.

Sur une autre page, la fiche technique avec les même colonne mais contenant des menus déroulants en cascade qui affinent recherche de produit au fur et à mesure.

Le problème est que par exemple pour le poisson il peut y avoir plusieurs entreprise qui en fournissent et je n'arrive pas à obtenir de liste en cascade liées, affinant la recherche et excluant les doublons.

Comme j'ai l'impression de ne pas être clair du tout je joint un fichier d'exemple ^^

Est ce que vous pourriez m'aider s'il vous plait ? Je galère pas mal sur ce problème...
J'ai fais beaucoup de recherche et ai trouvé beaucoup de résultat sur les liste en cascade mais aucunes n'étaient adaptées à se que je recherche.
Je ne sais pas trop comment formuler ce problème donc mes excuses par avance si le sujet à déjà était abordé ^^

Merci par avance !
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour Fastier, bienvenue sur XLD,

Voyez le fichier joint et ce code dans la 1ère feuille (clic droit sur l'onglet et Visualiser le code) :
VB:
Dim P As Range 'mémorise la variable

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set P = [H7:J20] 'à adapter
Set r = Intersect(Target, P.Resize(, 2))
If r Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For Each r In r
    r(1, 2).Resize(, IIf(r.Column = P.Columns(1).Column, 2, 1)) = ""
Next
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set P = [H7:J20] 'à adapter
P.Validation.Delete 'RAZ
If Intersect(ActiveCell, P) Is Nothing Then Exit Sub
Set P = Intersect(ActiveCell.EntireRow, P)
P(1).Validation.Add xlValidateList, Formula1:="=" & [Tableau2[Catégories]].Address
If ActiveCell.Column = P(2).Column Then
    If P(1) = "" Then P(1).Select Else Liste 2
ElseIf ActiveCell.Column = P(3).Column Then
    If P(2) = "" Then P(2).Select Else Liste 3
End If
End Sub

Sub Liste(col%)
Dim d As Object, tablo, x$, y$, i&
Set d = CreateObject("Scripting.Dictionary")
tablo = [Tableau1] 'matrice, plus rapide
x = P(1): y = P(2)
For i = 1 To UBound(tablo)
    If tablo(i, 1) = x And IIf(col = 3, tablo(i, 2) = y, True) Then d(tablo(i, col)) = ""
Next
With Sheets("Liste")
    .Columns(1).ClearContents
    If d.Count Then
        .[A1].Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        P(col).Validation.Add xlValidateList, Formula1:="=" & .[A1].CurrentRegion.Address(External:=True)
    End If
End With
End Sub
A+
 

Fichiers joints

job75

XLDnaute Barbatruc
En fait la liste pré-établie des catégories est inutile, utilisez ce fichier (2) :
VB:
Dim P As Range 'mémorise la variable

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set P = [F7:H20] 'à adapter
Set r = Intersect(Target, P.Resize(, 2))
If r Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For Each r In r
    r(1, 2).Resize(, IIf(r.Column = P.Columns(1).Column, 2, 1)) = ""
Next
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set P = [F7:H20] 'à adapter
P.Validation.Delete 'RAZ
If Intersect(ActiveCell, P) Is Nothing Then Exit Sub
Set P = Intersect(ActiveCell.EntireRow, P)
If ActiveCell.Column = P(1).Column Then
    Liste 1
ElseIf ActiveCell.Column = P(2).Column Then
    If P(1) = "" Then P(1).Select Else Liste 2
ElseIf ActiveCell.Column = P(3).Column Then
    If P(2) = "" Then P(2).Select Else Liste 3
End If
End Sub

Sub Liste(col%)
Dim d As Object, tablo, x$, y$, i&
Set d = CreateObject("Scripting.Dictionary")
tablo = [Tableau1] 'matrice, plus rapide
x = P(1): y = P(2)
For i = 1 To UBound(tablo)
    If IIf(col > 1, tablo(i, 1) = x And IIf(col = 3, tablo(i, 2) = y, True), True) Then d(tablo(i, col)) = ""
Next
With Sheets("Liste")
    .Columns(1).ClearContents
    If d.Count Then
        .[A1].Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        P(col).Validation.Add xlValidateList, Formula1:="=" & .[A1].CurrentRegion.Address(External:=True)
    End If
End With
End Sub
 

Fichiers joints

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas