Afficher une rubrique dans laquelle se trouve un produit en fonction de ses carac.

Option Explicit

Function DicoRubriques(ByVal RubCléDébut As Range, Optional ByVal Séparateur As String = vbLf) As Dictionary
Dim Te(), L As Long, Rub As String, TMen() As String, M As Long, Men As String, TRub() As String, R As Long
Te = ColUti(RubCléDébut).Value
Set DicoRubriques = New Dictionary
For L = 1 To UBound(Te)
   Rub = Te(L, 1)
   If IsEmpty(Te(L, 2)) Then ReDim TMen(-1 To -1) Else TMen = Split(Te(L, 2), Séparateur)
   For M = 0 To UBound(TMen)
      Men = TMen(M)
      If DicoRubriques.Exists(Men) Then
         TRub = DicoRubriques.Item(Men)
         R = UBound(TRub) + 1: ReDim Preserve TRub(0 To R)
      Else: R = 0: ReDim TRub(0 To 0): End If
      TRub(R) = Rub
      DicoRubriques.Item(Men) = TRub: Next M, L
End Function

Sub MàJRubriques(ByVal DicRub As Dictionary, ByVal ColDest As Range, ByVal PhrDébut As Range, ByVal Séparateur As String)
Dim Te(), Ts(), L As Long
Set PhrDébut = ColUti(PhrDébut): Te = PhrDébut.Value
ReDim Ts(1 To UBound(Te), 1 To 1)
For L = 1 To UBound(Te): Ts(L, 1) = Rubriques(DicRub, Te(L, 1), Séparateur): Next L
Intersect(ColDest.EntireColumn, PhrDébut.EntireRow).Value = Ts
End Sub

Function Rubriques(ByVal DicRub As Dictionary, ByVal Phrases As String, ByVal Séparateur As String) As String
Dim TSpl() As String, M As Long, TRub() As String, Mot As String, N As Long, Dic As New Dictionary
TSpl = Split(Phrases, Séparateur)
For M = 0 To UBound(TSpl): Mot = Trim$(TSpl(M))
   If DicRub.Exists(Mot) Then
      TRub = DicRub(Mot)
      For N = 0 To UBound(TRub): Dic(TRub(N)) = Empty: Next N: End If: Next M
Rubriques = Join(Dic.Keys, "-")
End Function

Option Explicit
Dim DicRub As Dictionary ' Type de la bibliothèque Scripting (référence "Microsoft Scripting Runtime")

Private Sub Worksheet_Activate()
ConstitDicRub
MàJRubriques DicRub, Me.Columns(77), Me.Cells(5, 76), "-"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 76 Or Target.Row < 5 Or Target.Count <> 1 Then Exit Sub
ConstitDicRub
Target.Offset(, 1).Value = Rubriques(DicRub, Target.Value, "-")
End Sub
Private Sub ConstitDicRub()
If DicRub Is Nothing Then Set DicRub = DicoRubriques(Feuil5.[A2:B2], vbLf)
End Sub
Private Sub Worksheet_Deactivate()
Set DicRub = Nothing
End Sub

Option Explicit
Dim DicMen As Dictionary, DicCas As Dictionary ' Type de la bibliothèque Scripting (référence "Microsoft Scripting Runtime")

Private Sub Worksheet_Activate()
ConstitDicMen
ConstitDicCas
MàJRubriques DicMen, Me.Columns(77), Me.Cells(5, 76), "-"
MàJRubriques DicCas, Me.Columns(78), Me.Cells(5, 10), "/"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row < 5 Or Target.Count <> 1 Then Exit Sub
Select Case Target.Column
   Case 76: ConstitDicMen: Target.EntireRow.Columns(77) = Rubriques(DicMen, Target.Value, "-")
   Case 10: ConstitDicCas: Target.EntireRow.Columns(78) = Rubriques(DicCas, Target.Value, "/")
   End Select
End Sub
Private Sub ConstitDicMen()
If DicMen Is Nothing Then Set DicMen = DicoRubriques(Feuil5.[A2:B2], vbLf)
End Sub
Private Sub ConstitDicCas()
If DicCas Is Nothing Then Set DicCas = DicoRubriques(Feuil6.[A2:B2], vbLf)
End Sub

Private Sub Worksheet_Deactivate()
Set DicMen = Nothing
Set DicCas = Nothing
End Sub