Supprimer des lignes quand un espace vide se trouve avec un @

Bonjour à tous,

Je suis en train de faire le tri dans ma base de données et je voudrais supprimer toutes les adresses avec où il manque le nom de domaine.

Exemple :

Je voudrais pouvoir supprimer jules@

(Mais garder jules@exemple.com)

J'ai déjà commencé à écrire une macro qui fonctionne pour supprimer la plupart des adresses mails et ainsi garder que les mails pros. Je voudrais donc pouvoir la compléter avec ce que je viens de vous expliquer.

Sub supprimer_mot_clef()

Dim onglet_data As Worksheet

Dim mot_clef(8) As String
Dim derniere_ligne As Long
Dim ligne_en_cours As Long
Dim i As Integer

'identifier l'onglet
Set onglet_data = Worksheets(1)

'identifier les mot clef
mot_clef(0) = "gmail"
mot_clef(1) = "yahoo"
mot_clef(2) = "outlook"
mot_clef(3) = "live"
mot_clef(4) = "orange"
mot_clef(5) = "free"
mot_clef(6) = "hotmail"
mot_clef(7) = "wanadoo"
mot_clef(8) = "laposte"

For i = 0 To 8 Step 1

    'boucle sur les lignes
    derniere_ligne = onglet_data.Cells(Rows.Count, 1).End(xlUp).Row

    For ligne_en_cours = derniere_ligne To 2 Step -1

        'comparer la phrase avec le mot clef cherché
        If InStr(onglet_data.Cells(ligne_en_cours, 1), mot_clef(i)) >= 1 Then
            onglet_data.Cells(ligne_en_cours, 1).EntireRow.Delete

        End If

    Next
Next
MsgBox ("Fin")

End Sub

Merci d'avance pour votre aide 🙂

Loïc

Bonjour,

un essai par dictionnaire qui évite la boucle sur le tableau mot_clef pour chaque ligne :

Sub supprimer_mot_clef()
Dim onglet_data As Worksheet
Dim Dico, ASup As Boolean
Dim derniere_ligne As Long
Dim ligne_en_cours As Long

'identifier l'onglet
Set onglet_data = Worksheets(1)

'création dictionnaire des mot clef
 Set Dico = CreateObject("Scripting.Dictionary")
Dico.Add "gmail", ""
Dico.Add "yahoo", ""
Dico.Add "outlook", ""
Dico.Add "live", ""
Dico.Add "orange", ""
Dico.Add "free", ""
Dico.Add "hotmail", ""
Dico.Add "wanadoo", ""
Dico.Add "laposte", ""

Application.ScreenUpdating = False
With onglet_data
    derniere_ligne = .Cells(Rows.Count, 1).End(xlUp).Row
    'boucle sur les lignes
    For ligne_en_cours = derniere_ligne To 2 Step -1
        ASup = False
        t = Split(.Cells(ligne_en_cours, 1).Value, "@")
        If UBound(t) > 0 Then
            If t(1) = "" Then
                ASup = True
            Else
                tt = Split(t(1), ".")
                If Dico.exists(tt(0)) Then ASup = True
            End If
        End If
        If ASup = True Then .Cells(ligne_en_cours, 1).EntireRow.Delete
    Next
End With
Application.ScreenUpdating = True
MsgBox ("Fin")
End Sub

A+

Bonjour,

Super idée je n'y avait même pas pensé !

Tout fonctionne parfaitement, un grand merci pour votre réactivité et pour avoir trouvé la solution du premier coup 🙂

Bonne fin de journée,

Loïc