Macro pour supprimer une cellule qui se termine par un point

Bonjour,

J'ai une macro qui me permet de supprimer les boîtes mails persos de me fichiers clients afin de garder seulement les mails pros. Je voudrais également supprimer toutes les adresses emails qui se termine par un point "."

Exemple : loic@exemple.com.

Malheureusement quand je rajoute le "." à supprimer dans mon dictionnaire, la macro me supprime tous les emails car il y toujours un point dans un mail (.fr, .com...), je n'arrive pas à indiquer à la macro que je veux supprimer uniquement les cellules qui se termine par un point

Voici ma macro actuelle :

Sub supprimer_mot_clef_A()

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

End Sub

Je tiens à préciser que suis débutant en VBA, on m'a bien aidé à faire la macro ci-dessus

Merci d'avance pour votre aide,

Loïc

Re,

A tester,

          tt = Split(t(1), ".")
          If UBound(tt) = 2 Then ASup = True

Erick,

Si j'ai bien compris, je dois remplacer :

If Dico.exists(tt(0)) Then ASup = True

par :

If UBound(tt) = 2 Then ASup = True

Ce qui donne :

Sub supprimer_mot_clef_A()

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 UBound(tt) = 2 Then ASup = True
            End If
        End If
        If ASup = True Then .Cells(ligne_en_cours, 1).EntireRow.Delete
    Next
End With
Application.ScreenUpdating = True

End Sub

C'est ça ?

Faites le test :

Sub Test()

Dim ASup As Boolean
Dim t As Variant
Dim tt As Variant

    ASup = False
    t = Split("aaaa@ek.com.", "@")

          tt = Split(t(1), ".")
          If UBound(tt) = 2 Then ASup = True
          Debug.Print "Nb points : " & UBound(tt) & ", Asup : " & ASup

End Sub

Bonjour Erick,

Je viens de faire le test mais ça ne fonctionne pas.

Ça marche de votre côté ?

Mettez un fichier exemple en ligne.

Erick,

Voilà un petit fichier exemple, j'ai essayé en modifiant un peu votre macro mais ça ne fonctionne pas de mon côté.

Oui,

Sub Test2()

Dim I As Integer
Dim ASup As Boolean
Dim t As Variant, tt As Variant
Dim AireATraiter As Range

    Set AireATraiter = Range("Tableau1[Mail]")
    For I = AireATraiter.Count To 1 Step -1
        ASup = False
        t = Split(AireATraiter(I), "@")
        tt = Split(t(1), ".")
        If UBound(tt) = 2 Then
          ASup = True
          Debug.Print AireATraiter(I) & ", nb points : " & UBound(tt) & ", Asup : " & ASup
          'AireATraiter(I).EntireRow.Delete
        End If
    Next I

  Set AireATraiter = Nothing

End Sub

J'ai reproduit exactement la même chose mais ça ne fonctionne toujours pas, voici mon fichier avec la macro :

J'avais neutralisé sciemment la ligne de code qui supprime la ligne. Le résultat s"affiche dans la fenêtre exécution exécution Ctrl-G pour contrôle.

Sub Test2()

Dim I As Integer
Dim ASup As Boolean
Dim t As Variant, tt As Variant
Dim AireATraiter As Range

    Set AireATraiter = Range("Tableau1[Mail]")
    For I = AireATraiter.Count To 1 Step -1
        ASup = False
        t = Split(AireATraiter(I), "@")
        tt = Split(t(1), ".")
        If UBound(tt) = 2 Then
          ASup = True
          Debug.Print AireATraiter(I) & ", nb points : " & UBound(tt) & ", Asup : " & ASup
          AireATraiter(I).EntireRow.Delete
        End If
    Next I

  Set AireATraiter = Nothing

End Sub

Il suffit de déneutraliser la ligne comme ci-dessus.

Effectivement ça marche très bien comme ça merci beaucoup. Dernière petite question, dans le but d'automatiser au maximum cette tâche, je voudrais que la macro s'applique dès lors qu'un fichier est importé, sans avoir à renommer la feuil et supprimer "Tableau1", j'ai essayé ça mais ça n'a pas l'air de fonctionner :

Sub supprimer_mail_avec_point()

Dim I As Integer
Dim ASup As Boolean
Dim t As Variant, tt As Variant
Dim AireATraiter As Range

    Set AireATraiter = ActiveSheet.Range("[Mail]")
    For I = AireATraiter.Count To 1 Step -1
        ASup = False
        t = Split(AireATraiter(I), "@")
        tt = Split(t(1), ".")
        If UBound(tt) = 2 Then
          ASup = True
          Debug.Print AireATraiter(I) & ", nb points : " & UBound(tt) & ", Asup : " & ASup
          AireATraiter(I).EntireRow.Delete
        End If
    Next I

  Set AireATraiter = Nothing

End Sub

Quel est votre code pour importer ce nouveau fichier ? Et comment sont présentées les données ?

J'importe de cette manière : Données → Obtenir des données → À partir d’un fichier → À partir d’un classeur → "Mon fichier" → Importer → Worksheet → Charger

Le titre Mail est toujours en cellule C1 ?

Non c'était juste pour l'exemple, dans mes vrais fichiers clients il est en cellule A1 et B1 et se nomme email_first et email_second

Quelle colonne faut-il traiter ?

Les deux si possible

Sub TestSupprimerLesAdresses()
    SupprimerLesAdresses ActiveSheet
End Sub

Sub SupprimerLesAdresses(ByVal Sh As Worksheet)

Dim I As Integer, DerniereLigne As Integer
Dim AireATraiter As Range

    With Sh
         DerniereLigne = .Cells.SpecialCells(xlCellTypeLastCell).Row
         Set AireATraiter = .Range(.Cells(2, 1), .Cells(DerniereLigne, 1))
         For I = AireATraiter.Count To 1 Step -1
             With AireATraiter(I)
                  If DoublePoints(.Value) Or DoublePoints(.Offset(0, 1).Value) Then .EntireRow.Delete
             End With
         Next I
    End With
    Set AireATraiter = Nothing

End Sub

Function DoublePoints(ByVal AdresseMail As String) As Boolean

Dim t As Variant, tt As Variant

    DoublePoints = False
    t = Split(AdresseMail, "@")
    tt = Split(t(1), ".")
    If UBound(tt) = 2 Then DoublePoints = True

End Function