Extraction adresse mails fichier Excel

Bonjour a toutes et à tous,

Pour un travail que je dois faire, je dois extraire toutes les adresses mails d'un fichier afin de pouvoir faire un envoi groupé.

Le problème est que ces mails se trouvent à l'intérieur des cellules avec beaucoup de textes, et ça me prendrait beaucoup de temps manuellement de copier ladresse mail de chaque cellule pour la mettre à côté.

J'ai essayé des formules, des tris... rien n'a marché.

Auriez-vous une astuce SVP? Je vous mets également le fichier Excel en pièce jointe afin que vous puissiez avoir une idée de la construction du fichier.

Merci!!

Bonjour,

Voici une proposition en utilisant des expressions régulières :

Sub ListerMails()
With Sheets(1)
    dl = .Cells(.Rows.Count, 1).End(xlUp).Row
    ReDim t(1 To dl)
    For i = 1 To dl
        temp = ExtraireMail(.Cells(i, 1).Value)
        If Not IsEmpty(temp) Then t(i) = Join(temp, " - ")
    Next i
End With
If Sheets.Count = 1 Then Sheets.Add after:=Sheets(sheets.count)
With Sheets(sheets.count)
    .Cells.Clear
    .Cells(1, 1).Resize(UBound(t)).Value = Application.Transpose(t)
End With
End Sub

Function ExtraireMail(chaine)
With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = "\w+@\w+\.\w{2,3}"
    If .test(chaine) Then Set omatch = .Execute(chaine) Else Exit Function
    ReDim t(omatch.Count - 1)
    For i = 0 To omatch.Count - 1
        t(i) = omatch(i).Value
    Next i
End With
ExtraireMail = t
End Function

Les résultats sont insérés dans la feuille 2 nouvellement créée. J'ai laissé les lignes vides pour faciliter les contrôles.

Cdlt,

Bonjour,

EDIT : Une autre solution :

Option Explicit
Sub ExtraireEmail()
Dim val, tb1, tb2
Dim noL As Long, i As Long, j As Long
Dim ok As Boolean

  ' Recherche Emails
  val = Worksheets("Feuil1").Cells(1, "A").CurrentRegion.Resize(, 2).Value
  noL = 1
  Do While noL <= UBound(val)
    tb1 = Split(val(noL, 1), vbLf)
    i = LBound(tb1)
    Do While i <= UBound(tb1) And ok = False
      tb2 = Split(tb1(i), " ")
      j = LBound(tb2)
      Do While j <= UBound(tb2) And ok = False
        If InStr(1, tb2(j), "@") > 0 Then
          val(noL, 1) = tb1(0)
          val(noL, 2) = tb2(j)
          ok = True
        End If
        j = j + 1
      Loop
      i = i + 1
    Loop
    If ok Then ok = False Else val(noL, 1) = tb1(0): val(noL, 2) = Empty
    noL = noL + 1
  Loop
  ' Mise en place des Noms et Emails colonnes 2 et 3
   With Worksheets("Feuil1").Cells(1, "A").CurrentRegion.Resize(, 2).Offset(0, 1)
    .ClearContents
    .Value = val
    .EntireColumn.AutoFit
  End With

End Sub

Bonjour

Bah comme j'y avais commencé... Une autre solution via deux simples petits codes et la fonction Convertir d'excel

1. Aller dans le menu Affichage et cliquer sur l"icone Macro --> Affichage des macros
2. Exécuter le code "Test"
3. Sélectionner toute la colonne A puis aller dans le menu Données --> menu Outils de conversion --> icone "Convertir"
4. Dans l'assistant :
-- laisser sur l'option "Délimiter" et cliquer sur suivant
-- à l'étape 2 de 3, cocher les cases "Tabulation" et "Espace" et cliquer sur "suivant" puis cliquer sur "Terminer"
5. Aller dans le menu Affichage et cliquer sur l'icone Macro
6. Exécuter le code Test2

Les adresses mail sont en colonne AX

Cordialement

Merci à tous!

J'ai pu résoudre mon problème grâce à vous, merci encore !