XL 2010 Liste déroulante cascade pour affiner recherche

[Fastier]

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 !

 

[job75]

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) :

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+

 

[job75]

En fait la liste pré-établie des catégories est inutile, utilisez ce fichier (2) :

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