Supprimer des lignes par rapport à une liste de mots

Bonjour,

Je voudrais supprimer des lignes d'une feuille contenant des caractères (fournisseurs).

Je pourrais écrire en dur dans le code exemple les noms comme ceci :

Sub Supp()
Dim I As Integer
  For I = [A65000].End(xlUp).Row To 1 Step -1
  If Not Cells(I, 1).Find("Amazon") Is Nothing Or _
     Not Cells(I, 1).Find("Gros Bill") Is Nothing Or _
      Not Cells(I, 1).Find("Boulanger") Is Nothing Then Rows(I).Delete
  Next I
End Sub

Mais je ne veux pas le faire ainsi car ma liste est longue et sera modifiable.

J'ai une feuille "Sup" qui contient en colonne A les fournisseurs à supprimer.

J'ai une feuille qui contient le tableau de base avec tous les fournisseurs qui se nomme fournisseurs.

Le nom des fournisseurs se trouve en colonne B de cette feuille. Feuille qui contient des données de la colonne A à I.

Je voudrais pouvoir faire via une macro la création d'une nouvelle feuille qui affiche ce tableau en ayant supprimer les fournisseurs non désirés.

Merci pour votre aide.

Bonjour

Cette macro que tu mets dans un module

Sub suppr()

Dim cellRecherche As Range, Mot As String

Mot = InputBox("Mot à rechercher", "Effacement ligne")

Set cellRecherche = ActiveSheet.Cells.Find(Mot, , , xlPart)

While Not cellRecherche Is Nothing

cellRecherche.EntireRow.Delete

Set cellRecherche = ActiveSheet.Cells.Find(Mot, , , xlPart)

Wend

End Sub

Cordialement

Bonjour et merci Joco7915 pour ta réponse.

Que je travaille en dur ou comme tu le proposes via une InputBox cela est pareil, voir pire car si je dois retaper 40, 200 mots

Je veux juste éviter de les écrire en dur dans la code car d'une part c'est très long et de plus cela est modifiable.

Donc je veux éviter de revenir régulièrement sur le code.

Merci pour ta proposition et ton regard sur ma demande

Bonsoir Tespark, Joco7915, le forum,

Un essai....

Option Explicit
Option Compare Text

Sub Ligne_supprimer()
    Dim c As Range, i As Long

    Application.ScreenUpdating = False

    With Sheets("Feuil1")
     For i = .Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
        Set c = Sheets("Sup").Columns(1).Find(Range("B" & i).Value)
         If Not c Is Nothing Then Rows(i).Delete
     Next i
    End With
End Sub

CTRL + e pour lancer la macro

Cordialement,

Bonjour,

Un test rapide. Si tu as beaucoup de ligne une formule NB.SI ira plus vite que de regarder ligne à ligne.

Bonne soirée.

Re,

Après quelques recherches, voici un code de Klin89 qui devrait être plus rapide...(Merci à lui, ).

Option Explicit
Sub test()
 Dim rngCrit As Range, r As Range, vCrit, dico As Object
    Set dico = CreateObject("scripting.dictionary")
        dico.CompareMode = 1
     Application.ScreenUpdating = False

    With Sheets("Sup") 'la feuille où se situe ta liste
        Set rngCrit = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row) 'a adapter
        For Each r In rngCrit
            dico(r.Value) = Empty
        Next
    End With

    vCrit = dico.keys

    With Sheets("Feuil1").Range("B1").CurrentRegion
        .Parent.AutoFilterMode = False
        .AutoFilter 1, vCrit, 7
        .Offset(1).EntireRow.Delete
        .AutoFilter
    End With

    Set dico = Nothing
     Application.ScreenUpdating = True
End Sub

Cordialement,

Bonjour à tous,

Voici, encore, une proposition, cette fois-ci en mémoire, avec un test sur la colonne A uniquement et surtout avec une liste hypothétique nommée "Liste" (!!! sans cellule vide !!!) contenant les valeurs entrainant une suppression de ligne.

Il faudra adapter le nom de la feuille.

sub test()

dim tlignes()

with sheets("feuille") '<<< ADAPTER
    dl = .cells(.rows.count, 1) end(xlup).row
    redim tlignes(1 to dl, 1 to .columns.count)
    for i = 1 to dl
        if evaluate("SUMPRODUCT(COUNTIF(A" & i &", ""*"" & Liste & ""*""))") = 0 then '<<< CREER LA LISTE
            n = n + 1
            for k = 1 to .columns.count
                tlignes(n, k) = .cells(i, k).value
            next k
        end if
    next i
    if n > 0 then
        .range("1:" & dl).clearcontents
        .cells(1,1).resize(n, .columns.count) = tlignes
    end if
end with

end sub

Cdlt,

Bonjour,

Merci à vous, c'est parfait.

Du coup je ne sais pas à qui mettre en résolu