Identifier les cellules qui contiennent un mot d'une liste

Bonjour à tous,

J'ai un classeur avec deux feuilles:

La feuille 1 contient de A2 à A2525 une liste de personnages séparés par des virgules+espace.

Par exemple:

A1= Pierre A. Dupont, Virginie Bernard, Harry Potter

A2= SuperM

A3= Bruce Wayne, Virginie Bernard

Remarque 1 : Un même personnage peut apparaître sur plusieurs lignes.

Remarque 2 : Toutes les lignes contiennent 1 à 6 personnages.

La feuille 2 contient de A2 à A96 une liste de personnages pertinents, avec 1 nom unique par cellule.

Par exemple:

A1= Bruce Wayne

A2= Wonder Woman

A3= Harry Potter

Ce que je souhaite, c'est nettoyer ma première feuille (ou en créer une nouvelle) pour ne conserver que les lignes qui contiennent au moins 1 des noms pertinents de la colonne A feuille 2.

Auriez-vous une solution à proposer ?

Merci de m'avoir lu et à bientôt

Edit: j'ajoute un fichier en PJ avec la même disposition des données. Il ne s'agit pas du fichier original sur lequel je travaille, juste un brouillon pour illustrer mon topic.

bonjour,

une solution possible

Sub aargh()
    Set ws1 = Sheets("feuil1")
    Set ws2 = Sheets("feuil2")
    dlws1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Set r = ws1.Range("A2:A" & dlws1)
    dlws2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    Set dico = CreateObject("scripting.dictionary")
    For i = 2 To dlws2
        Set re = r.Find(ws2.Cells(i, 1), lookat:=xlPart)
        If Not re Is Nothing Then
            fa = re.Address
            Do
                If Not dico.exists(re.Value) Then dico.Add re.Value, ""
                Set re = r.FindNext(re)
            Loop Until re Is Nothing Or re.Address = fa
        End If
    Next i
    r.Delete
    ws1.Range("A2").Resize(dico.Count, 1).Value = Application.Transpose(dico.keys)
End Sub

Bonjour h2so4 et merci pour ta proposition.

Lorsque j'ai exécuté la macro, j'ai obtenu une Erreur d'exécution '13': Incompatibilité de type, avec cette dernière ligne surlignée en jaune:

ws1.Range("A2").Resize(dico.Count, 1).Value = Application.Transpose(dico.keys)

En outre, toutes mes données en feuille 1 de A2 à A2525 ont été supprimées.

Je n'ai jamais travaillé avec des macros, est-ce que tu connaîtrais une solution avec une formule ?

Si cela peut aider à mieux comprendre mon sujet, je joint un classeur qui contient le même type de données avec la même disposition.

Merci et bonne fin de journée !

Bonjour le Forum,

Bonjour Because, h2so4,

un essai en fichier joint les explications sont dans le fichier

Cordialement

bonjour,

je n'ai pas trouvé d'où vient l'erreur que tu rencontres. voici une autre solution.

Sub aargh()
    Set ws1 = Sheets("feuil1")
    Set ws2 = Sheets("feuil2")
    dlws1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Set r = ws1.Range("A2:A" & dlws1)
    dlws2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    Set dico = CreateObject("scripting.dictionary")
    For i = 2 To dlws2
        Set re = r.Find(ws2.Cells(i, 1), lookat:=xlPart)
        If Not re Is Nothing Then
            fa = re.Address
            Do
                a = re.Value
                If Not dico.exists(re.Value) Then dico.Add a, a
                Set re = r.FindNext(re)
            Loop Until re Is Nothing Or re.Address = fa
        End If
    Next i
    r.Delete
    a = dico.keys
    For i = LBound(a) To UBound(a)
        ws1.Cells(i + 1, 1).Value = a(i)
    Next i
End Sub

Bonjour Debutant86, merci pour ta solution, elle a bien fonctionné

H2so4, j'ai probablement fait une fausse manipulation du fait de mes lacunes avec les macros, mais merci beaucoup pour tes propositions.

Bonne journée à tous les deux