Microsoft 365 Si tous les légumes d'une chaîne se trouvent dans une autre chaîne alors on pourra supprimer cette chaîne

Private Sub Worksheet_Activate()
Dim d As Object, tablo, resu$(), i&, s, x$, n&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("tout").UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To Rows.Count, 1 To 1)
For i = 2 To UBound(tablo)
    s = Split(tablo(i, 1), "/")
    If UBound(s) > 0 Then
        tri s, 0, UBound(s) 'classement alphabétique sur chaque ligne
        tablo(i, 1) = Join(s, "/")
    End If
    x = tablo(i, 1)
    If x <> "" Then
        If Not d.exists(x) Then
            d(x) = ""
            n = n + 1
            resu(n, 1) = x
        End If
    End If
Next
'---restitution---
If FilterMode Then ShowAllData: DrawingObjects(1).Text = "Filtrer" 'si la feuille est filtrée
With [A2] '1ère cellule de restitution, à adapter
    If n Then
        .Resize(n) = resu
        .Offset(, 1).Resize(n) = "=COUNTIF(C1,SUBSTITUTE(RC[-1],""/"",""*""))"
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
Application.Goto [A1], True 'cadrage
End Sub

Sub Filtrer_RAZ()
With DrawingObjects(1)
    If .Text = "Filtrer" Then UsedRange.Resize(, 2).AutoFilter 2, 1 Else If FilterMode Then ShowAllData
    .Text = IIf(.Text = "RAZ", "Filtrer", "RAZ")
End With
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, s, ub%, x$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("tout").UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To Rows.Count, 1 To 1)
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    s = Split(x, "/")
    ub = UBound(s)
    If ub > 0 Then
        tri s, 0, ub 'classement alphabétique sur chaque ligne
        x = Join(s, " / ") 'encadrement par des espaces
    End If
    If x <> "" Then d(x) = ""
Next
'---restitution---
If FilterMode Then ShowAllData: DrawingObjects(1).Text = "Filtrer" 'si la feuille est filtrée
With [A2] '1ère cellule de restitution, à adapter
    If d.Count Then
        .Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        .Resize(d.Count).Sort .Cells, xlAscending, Header:=xlNo 'tri sur la 1ère colonne
        .Offset(, 1).Resize(d.Count) = "=COUNTIF(C[-1],SUBSTITUTE(RC[-1],""/"",""*""))"
    End If
    .Offset(d.Count).Resize(Rows.Count - d.Count - .Row + 1, 2).ClearContents 'RAZ en dessous
    .EntireColumn.AutoFit 'ajustement largeur
End With
Application.Goto [A1], True 'cadrage
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, tablo, i&, s, ub%, x$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("tout").UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To Rows.Count, 1 To 1)
For i = 2 To UBound(tablo)
    x = tablo(i, 1)
    s = Split(x, "/")
    ub = UBound(s)
    If ub > 0 Then
        tri s, 0, ub 'classement alphabétique sur chaque ligne
        x = "/ " & Join(s, " / ") & " /" 'encadrement par des espaces
    End If
    If x <> "" Then d(x) = ""
Next
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData: DrawingObjects(1).Text = "Filtrer" 'si la feuille est filtrée
With [A2] '1ère cellule de restitution, à adapter
    If d.Count Then
        With .Resize(d.Count)
            .Value = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
            .Offset(, 1) = "=COUNTIF(C[-1],SUBSTITUTE(RC[-1],""/"",""*""))"
            .Offset(, 1) = .Offset(, 1).Value 'supprime les formules
            .Replace " / ", "/", xlPart 'supprime les espaces au milieu
            .Replace "/ ", "" 'supprime l'espace et le slash à gauche
            .Replace " /", "" 'supprime l'espace et le slash à droite
            .Resize(, 2).Sort .Cells, xlAscending, Header:=xlNo 'tri sur la 1ère colonne
        End With
    End If
    .Offset(d.Count).Resize(Rows.Count - d.Count - .Row + 1, 2).ClearContents 'RAZ en dessous
    .EntireColumn.AutoFit 'ajustement largeur
End With
Application.Goto [A1], True 'cadrage
End Sub