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

[carlos]

Bonjour,
Je cherche à nettoyer une colonne d'excel. Voir PJ.
par exemple si j'ai dans la même colonne :

Ligne 2 --> Pois/Carotte
Ligne 3 --> Pois/Carotte/Tomate
Ligne 4 --> Pois/Carotte/Asperge/Céleri

Ligne 23 --> Pois/Carotte/Tomate/Poireau

Principe : Si tous les légumes d'une chaîne se trouvent dans une autre chaîne alors on pourra supprimer cette chaîne
Donc dans mon exemple on pourra supprimer la ligne 2 et la ligne 3
J’espère avoir été assez clair.
Bonne soirée

 

[chris]

Bonjour

Une solution PowerQuery, intégré à Excel

 

[carlos]

Bonsoir Chris,
Ca marche mais je ne comprends pas comment tu as fait.
J'aimerais pouvoir le refaire si je change ma colonne de donnée.
Je ne vois pas de macro et ne comprends pas comment marche PowerQuery.
Merci
Carlos

 

[job75]

Bonsoir carlos, chris,

Voyez le fichier joint et ces macros dans le code de la feuille "Résultat" :

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

La macro principale se déclenche quand on active la feuille.

Les lignes de fréquence > 1 ne sont pas supprimées mais masquées via le bouton.

Bonne nuit.

 

[chris]

RE à tous

J'ai comparé nos résultats :

• je trouve 7 faux doubles et 8 faux simples dans les résultats de job75
• j'avais des problèmes avec Courge et Courgette que j'ai corrigé

Pour voir les requêtes PowerQuery : Données, Obtenir des données, Lancer PowerQuery
Il y a 3 requêtes :

• Uniques qui dédoublonne les 5588 lignes en 213 (comme le fait le code de job75
• Doublons qui repère les combinatoires existant dans les uniques (25)
• Final qui retire les doublons de Uniques

Pour chaque requêtes on peut voir les actions/étapes dans le volet de droite et les rouages en bout de ligne précise le détail de l'action

Pour les actions, dans 95% des cas on passe par les Onglets ou le clic droit, on ne code pas.
Si tu as des questions sur certaines actions, j'y répondrai demain en fin d'après-midi...

 

[carlos]

Job75,Chris,
Wahou, je suis impressionné par la qualité et la rapidité de vos réponses.
@chris Je vais approfondir le PowerQuery.
@job75 Bonne idée de trier les lignes et d'utiliser le dictionnary.
Super et merci à tous les 2.
Je risque de vous solliciter à nouveau car pour arriver à ces 5588 lignes j'ai créé un code qui marche mais qui met 1 minute à tourner. Je vais créer un autre post.
Encore merci à tous les 2

 

[mapomme]

Bonjour @carlos , @chris , @job75 ,

Voir ici un exemple de données qui semblent poser une difficulté avec la méthode de @job75. (à condition d'avoir bien compris la question)

 

[job75]

Bonjour carlos, chris, mapomme, le forum,

Ah oui je n'avais pas vu le problème Courge et Courgette.

Il suffit d'ajouter des espaces pour encadrer, voyez ce fichier (2) :

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

J'ai aussi ajouté un tri sur la 1ère colonne, c'est plus simple pour vérifier.

Bonne journée.

 

[carlos]

Bravo .

 

[job75]

Bon le fichier (2) ne va pas, il y a encore 8 lignes de trop comme l'a dit chris.

Il faut mettre des espaces aussi sur les bords, fichier (3) :

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

Maintenant après filtrage il y a bien 188 lignes comme sur le fichier de chris.

 

[carlos]

Cest de l'horlogerie.
Passer de 5588 lignes à 188 cela aurait ete tres long à la main.
Merci vraiment beaucoup.

 

[chris]

RE à tous

As-tu regardé PowerQuery ?
Le résultat est juste je pense et trié tant dans chaque ligne que les lignes elles-mêmes...

 

[job75]

Oui chris toi et moi nous avons le même résultat, à part le tri de la colonne qui diffère un peu.

 

[mapomme]

Bonsoir @job75, @chris,

Je veux bien être transparent mais avez-vous testé le jeu d'essai du message #7.
Sauf erreur, vous n'obtenez pas les mêmes résultats. Non ?

Ou bien je déraille (ce qui n'est pas exclus)

 

[job75]

Sauf erreur, vous n'obtenez pas les mêmes résultats. Non ?

Les résultats sont les mêmes, après filtrage bien sûr chez moi.

Compare les fichiers des posts #5 et #10 => 188 lignes avec les mêmes textes.