EXTRAIRE EMAIL (niveau expert)

Bonjour à tous.

Après une journée passée à chercher la solution sur le net, je me suis résigné à demander de l'aide.

Mon besoin :

Depuis un fichier Excel maître, j'aimerais une macro exécutable qui aille récupérer tous les e-mails des fichiers Excel contenus dans un dossier.

EXCEL MAITRE ----> DOSSIER A ------> EXCEL 1 - EXCEL 2 - EXCEL 3 .... etc...

Dans les fichiers EXCEL 1, EXCEL 2 et EXCEL 3, nous avons des adresses e-mails éparpillées dans les cellules de toute la feuille sans aucune règle spécifique.

Pour résumé il faut procéder en 2 étapes :

1 - Connaître la requête d'extraction des adresses e-mails avec les conditions suivantes :

Dans toute la feuille, dans chaque cellule, récupérer l'adresse quand il y a un @ en prenant tous les caractères avant le @

(jusqu'à ce qu'il y ait un "espace" ou "virgule" ou "point virgule") et après le @ pareil.

2 - Répéter l'étape 1 pour chaque fichier Excel contenu dans le dossier A

Merci pour votre collaboration.

Cordialement,

Aurélie.

Bonjour,

Dev rapide, assez lent je pense, si qqun a mieux je suis preneur. (penser a modifier le repertoire ou se trouve les fichiers et modifier le nom de l'onglet où ecrire le résultat.

A copier dans une macro.

Sub MAILRECUP()

Dim num_cellule As Double

Dim montab() As String
Dim objFSO, objDossier, objFichier As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim repertoire As String

repertoire = "c:\excel"

'Determine ou on doit lire les données.
Dim Flecture As Excel.Workbook

'Determine ou on doit ecrire les données.
Dim maitre As Worksheet
Set maitre = Workbooks(ActiveWorkbook.Name).Worksheets("Feuil1")  'Feuil1 a changer si nom onlget different
num_cellule = 3 'On ecrit a partir de la ligne 3

'Determine ou on doit lire les données.
Dim w As Worksheet
Dim s As String

'init tableau
ReDim montab(0)

'Pour chaque fichier
Set objDossier = objFSO.GetFolder(repertoire)
If (objDossier.Files.Count > 0) Then
     For Each objFichier In objDossier.Files
        If objFSO.GetExtensionName(objFichier) = "xls" Then
            Set Flecture = Workbooks.Open(objFichier.Path, , ReadOnly)

            'Pour chaque feuille on recherche adresse mail et on la met dans le tableau montab
            For Each w In Flecture.Worksheets
                ' Pour chaque cellule
                For Each c In Flecture.Worksheets(w.Name).Range("A1:IV65535")
                    If InStr(1, c.Value, "@") > 0 Then
                    renvoimail_ds_tableau c.Value, montab
                    End If
                Next
            Next
        Flecture.Close
        End If
    Next
End If

Set objDossier = Nothing
Set objFSO = Nothing

For i = LBound(montab) To UBound(montab)
    maitre.Cells(num_cellule, 1) = montab(i)
    num_cellule = num_cellule + 1
Next

End Sub

Function renvoimail_ds_tableau(chaine As String, ByRef montableau() As String) As String

Dim i As Integer

If InStr(1, chaine, ",") > 0 Or InStr(1, chaine, ";") > 0 Or InStr(1, chaine, " ") > 0 Then
    chaine = Replace(chaine, ",", "||")
    chaine = Replace(chaine, " ", "||")
    chaine = Replace(chaine, ";", "||")

    mesadresses = Split(chaine, "||")
    For i = LBound(mesadresses) To UBound(mesadresses)
        If InStr(1, mesadresses(i), "@") Then
            If montableau(UBound(montableau)) <> "" Then
            ReDim Preserve montableau(UBound(montableau) + 1) 'Ajoute
           End If
         montableau(UBound(montableau)) = mesadresses(i)

        End If
    Next
Else
            If montableau(UBound(montableau)) <> "" Then
            ReDim Preserve montableau(UBound(montableau) + 1) 'Ajoute
            End If
            montableau(UBound(montableau)) = chaine
End If
End Function

Super c'est exactement ce qu'il me fallait !

C'est vrai que le temps de traitement est assez long... mais l'avantage c'est que cette méthode fonctionnera pour de nombreux post sur le forum relatant cette problématique d'extraction d'adresse e-mail.

Pour ceux qui veulent enlever les guillemets ça se passe comme ceci :

If InStr(1, chaine, ",") > 0 Or InStr(1, chaine, ";") > 0 Or InStr(1, chaine, " ") > 0 Or InStr(1, chaine, """") > 0 Then
    chaine = Replace(chaine, ",", "||")
    chaine = Replace(chaine, " ", "||")
    chaine = Replace(chaine, ";", "||")
    chaine = Replace(chaine, """", "||")

Encore un grand merci pour ta réponse Bigdams !

Cordialement,

Aurélie.