rene1976
Goto Top

Excel - alle E-mail Adressen von einem Blatt in neues Blatt extrahieren

Hallo,

ich habe von einem Kollegen eine Excel Tabelle bekommen, in der viele E-Mail-Adressen stecken.
Leider sind die E-Mail-Adressen nicht nur in einer Spalte, sondern bunt verteilt.

Gibt es in Excel (ohne Programmieren) eine Möglichkeit, alle E-Mail herauszusuchen und in der Datei in ein neues Blatt in eine Spalte zu kopieren.
Dabei sollte jede E-Mail nur einmal in das neue Blatt kopiert werden, d.h. ohne Duplikate.

Besten Dank.

Rene

Content-Key: 43719097510

Url: https://administrator.de/contentid/43719097510

Printed on: December 6, 2023 at 21:12 o'clock

Member: Nebellicht
Nebellicht Nov 21, 2023 at 12:20:16 (UTC)
Goto Top
Hallo.
Ohne Duplikate: Alle E-Mails sortieren... dann die doppelten entfernen.
E-Mails herausholen... als CSV exportieren: Dann mit einem Textprogramm nach @ suchen... Fertig. Natürlich dieser Schritt vor dem obigen. Gruß nbll
Member: katrin11
katrin11 Nov 21, 2023 updated at 14:08:53 (UTC)
Goto Top
Hi.
Gibt es in Excel (ohne Programmieren)
Keine Angst vorm Programmieren, das kann jeder wenn er nur will ..., Hauptsache man beschäftigt sich mit dem Code und weiß em Ende was er tut ­čśŐ
Mit folgendem Code können auch mehrere Adressen in einer Zelle stehen und auch weiterer beliebiger Text, es werden nur die reinen Mail-Adressen extrahiert und ohne Duplikate in ein Sheet mit dem Namen "Ergebnis" kopiert.
Sub EMailsSuchen()
    Dim zielSheet As Worksheet, ws As Worksheet, regex As Object, cell As Range
    ' zielsheet  
    Set zielSheet = Sheets.Add(After:=Sheets(Sheets.Count))
    zielSheet.Name = "Ergebnis"  
    ' regex  
    Set regex = CreateObject("vbscript.regexp")  
    regex.Global = True: regex.IgnoreCase = True
    regex.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,}\b"  
    ' für jedes sheet  
    For Each ws In Sheets
        ' jede Zelle im Sheet  
        For Each cell In ws.UsedRange
            ' suche mails  
            Set matches = regex.Execute(cell.Value)
            ' wenn Ergebnis  
            If matches.Count > 0 Then
                ' für jede Mail der Zelle  
                For Each Match In matches
                    ' wenn mail noch nicht gefunden wurde  
                    If zielSheet.Range("A:A").Find(Match.Value, LookIn:=xlValues) Is Nothing Then  
                        ' mail in neue Zelle schreiben  
                        zielSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Match.Value  
                    End If
                Next
            End If
        Next
    Next
    ' Ergebnis anzeigen  
    zielSheet.Activate
End Sub

Gruß Katrin
Member: Thomas2
Thomas2 Nov 21, 2023 at 13:55:58 (UTC)
Goto Top
Hi,

Kopie des Dokuments erstellen und dann in der Kopie:
Alle Spalten mit Emails in eine Spalte kopieren. In der ersten Zeile die Spaltenüberschrift machen und über Daten > Filtern die Filterung einschalten.
Dann über das Dropdown des Filters der Überschriftenzelle auf "enthält nicht @" filtern und alle Einträge die keine Mailadresse sind finden. Diese nun alle markieren, löschen und den Filter rauswerfen. Übrig bleiben alle Mailadressen. Jetzt nochmal sortieren um die Lücken zu schließen und über Daten -> Duplikate entfernen die doppelten Adressen rauslöschen.

Gruß,
Thomas
Member: Rene1976
Rene1976 Nov 21, 2023 at 14:20:26 (UTC)
Goto Top
Hallo,

vielen Dank für eure tollen Tipps.
Werde ich morgen probieren.

Gruß,

Rene