Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1684to1688
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

in Excel nur Emailadresse auslesen und kopieren

in Excel nur Emailadresse auslesen und kopieren
10.04.2019 07:37:28
Heidi
Guten Morgen,
vielleicht kann mir jemand helfen, ich bräuchte eine Formel oder VBA-Code um in einer Exceltabelle nur die Emailadressen in ein anderes Tabellenblatt untereinander kopiert.
Es sind viele Emailadressen.
Beispiel:
Mustermann, Max (Abteilung)
Ich benötige aber nur die max.mustermann@bla.com
Dankeschön und Gruß
Heidi

22
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 07:54:01
Torsten
Hallo Heidi,
Frage. Sind die Email Adressen alle in der gleichen Spalte, oder wahllos verteilt auf dem Tabellenblatt?
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 07:57:31
Heidi
Hallo Torsten,
sie stehen in A2 / A3 / A4 - sind ganz viele ...
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 08:10:01
Heidi
Hallo nochmal,
ich möchte aus einem Outlook-Verteiler die Email nach Excel zu einer .csv Datei exportieren und es kann sein, dass es hier so an die 1000 Emailadressen sind.
Dankeschön.
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 10:12:44
Heidi
Hallo zusammen,
gibt es hierfür vielleicht ein Makro?
Danke und Gruß
Heidi
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 10:14:41
PeterK
Hallo
Sind die Addressen bereits in Excel oder musst Du sie erst aus Outlook holen?
Kannst Du ein Beispiel mit mehreren Addressen hochladen?
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 10:32:24
Nepumuk
Hallo Heidi,
teste mal:
Option Explicit
Public Sub CopyMailAddress()
Dim objCell As Range
Dim strFirstAddress As String
Dim lngRow As Long
Worksheets("Tabelle2").Columns(1).ClearContents
With Worksheets("Tabelle1").Cells
Set objCell = .Find(What:="@", LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
lngRow = lngRow + 1
Call objCell.Copy(Destination:= _
Worksheets("Tabelle2").Cells(lngRow, 1))
Set objCell = .FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Set objCell = Nothing
End If
End With
End Sub

Du musst eventuell die Tabellennamen anpassen. Im Programm ist die Ausgangstabelle die "Tabelle1", die Tabelle in welche die Adressen kopiert werden sollen die "Tabelle2".
Gruß
Nepumuk
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 12:59:49
Heidi
Hallo Nepumuk,
habe den Code getestet, aber leider sieht das Ergebnis so aus:
Martin, Heidi (GP TP SW) max.mustermann@max.com;Martin, Heidi (GP TP SW)max.mustermann@max.com;Martin, Heidi (GP TP SW)max.mustermann@max.com;
So sieht auch die Ursprungsliste in Excel aus und ich möchte eben nur die Emailadressen: max.mustermann@max.com und wenn möglich, alle untereinander?
Danke schon Mal :-)
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 13:31:40
Nepumuk
Hallo Heidi,
so ok?
Option Explicit

Public Sub CopyMailAddress()
    Dim objCell As Range
    Dim strFirstAddress As String, astrMailAddress() As String
    Dim lngRow As Long, ialngIndex As Long
    Worksheets("Tabelle2").Columns(1).ClearContents
    With Worksheets("Tabelle1").Cells
        Set objCell = .Find(What:="@", LookIn:=xlValues, _
            LookAt:=xlPart, MatchCase:=False)
        If Not objCell Is Nothing Then
            strFirstAddress = objCell.Address
            Do
                astrMailAddress = GetMailAddress(strText:=objCell.Text)
                For ialngIndex = LBound(astrMailAddress) To UBound(astrMailAddress)
                    lngRow = lngRow + 1
                    Worksheets("Tabelle2").Cells(lngRow, 1).Value = astrMailAddress(ialngIndex)
                Next
                Set objCell = .FindNext(After:=objCell)
            Loop Until objCell.Address = strFirstAddress
            Set objCell = Nothing
        End If
    End With
    Call Worksheets("Tabelle2").Columns(1).RemoveDuplicates(Columns:=1, Header:=xlNo)
End Sub

Private Function GetMailAddress(ByVal strText As String) As String()
    Dim objRegEx As Object, objMatch As Object
    Dim astrTemp() As String
    Dim ialngIndex As Long
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .Global = True
        .Pattern = "[a-z0-9\-\.]{2,63}@[a-z0-9\-\.]{2,63}\.[a-z]{2,4}"
        .IgnoreCase = True
        Set objMatch = .Execute(strText)
    End With
    Redim astrTemp(0 To objMatch.Count - 1)
    For ialngIndex = 0 To objMatch.Count - 1
        astrTemp(ialngIndex) = objMatch.Item(ialngIndex).Value
    Next
    GetMailAddress = astrTemp
    Set objRegEx = Nothing
    Set objMatch = Nothing
End Function

Gruß
Nepumuk
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 13:40:23
Heidi
Hallo Nepumuk,
sieht schon gut aus, aber es sind ca. 1000 Emailadressen und diese sind aus Outlook heraus nach Excel kopiert, er schreibt mir die Adressen in Zelle A1 / A2 / A3 - er übernimmt dann leider nur ca. 300 Emailadressen. Weiß nicht, wie ich es anders kopieren kann?
Mache ich hier was falsch?
Danke
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 14:12:18
Nepumuk
Hallo Heidi,
ich lösche am Ende des Makros alle doppelten. Kann es daran liegen?
du kannst ja diese Zeile:
Call Worksheets("Tabelle2").Columns(1).RemoveDuplicates(Columns:=1, Header:=xlNo)
mal auskommentieren. Wenn deine Anzahl dann ungefähr hin kommt, dann hast du viele doppelte drin.
In deinem Beispiel waren ja alle 3 Adressen identisch.
Gruß
Nepumuk
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 14:25:24
Heidi
Hallo Nepumuk,
es sind wirklich 1000 Emailadressen. Ich kann diese in Outlook kopieren und in Excel einfügen, aber leider schreibt er die Emailadressen nicht in eine Zeile, sondern in A1, A2 und A3. Er unterbricht praktisch die Emailadressen, deshalb erkennt er nach dem Makro nur um die 300 Stück. Vielleicht gibt es in Excel eine Begrenzung an Zeichen, bin mir nicht sicher, ansonsten würde das Makro ja gut funktionieren. Gibt es da noch eine andere Möglichkeit, wie ich die ganzen Adressen in eine Zeile kriegen und dann das Makro funktioniert. Ich muss hier eine CSV-Datei erstellen.
Vielen lieben Dank!
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 14:33:26
Nepumuk
Hallo Heidi,
so besser?
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef psa() As Any) As Long

Public Sub CopyMailAddress()
    Dim objCell As Range
    Dim strFirstAddress As String, astrMailAddress() As String
    Dim lngColumn As Long, ialngIndex As Long
    Worksheets("Tabelle2").Rows(1).ClearContents
    With Worksheets("Tabelle1").Cells
        Set objCell = .Find(What:="@", LookIn:=xlValues, _
            LookAt:=xlPart, MatchCase:=False)
        If Not objCell Is Nothing Then
            strFirstAddress = objCell.Address
            Do
                astrMailAddress = GetMailAddress(strText:=objCell.Text)
                If SafeArrayGetDim(astrMailAddress) > 0 Then
                    For ialngIndex = LBound(astrMailAddress) To UBound(astrMailAddress)
                        lngColumn = lngColumn + 1
                        Worksheets("Tabelle2").Cells(1, lngColumn).Value = astrMailAddress(ialngIndex)
                    Next
                End If
                Set objCell = .FindNext(After:=objCell)
            Loop Until objCell.Address = strFirstAddress
            Set objCell = Nothing
        End If
    End With
End Sub

Private Function GetMailAddress(ByVal strText As String) As String()
    Dim objRegEx As Object, objMatch As Object
    Dim astrTemp() As String
    Dim ialngIndex As Long
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .Global = True
        .Pattern = "[a-z0-9\-\.]{2,63}@[a-z0-9\-\.]{2,63}\.[a-z]{2,4}"
        .IgnoreCase = True
        Set objMatch = .Execute(strText)
    End With
    With objMatch
        If .Count > 0 Then
            Redim astrTemp(0 To .Count - 1)
            For ialngIndex = 0 To .Count - 1
                astrTemp(ialngIndex) = .Item(ialngIndex).Value
            Next
            GetMailAddress = astrTemp
        End If
    End With
    Set objRegEx = Nothing
    Set objMatch = Nothing
End Function

Gruß
Nepumuk
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 14:40:22
Heidi
Hallo,
dein Makro ist toll, aber leider nimmt er immer nur die Daten aus der Spalte A1 (ca. 300 Stück) mehr übernimmt er einfach nicht.
Dann muss ich es vielleicht anders versuchen. Schade, vielen lieben Dank trotzdem.
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 14:44:53
Nepumuk
Hallo Heidi,
das kann nicht sein, denn:
With Worksheets("Tabelle1").Cells
legt fest dass in allen Zellen der Tabelle gesucht wird.
Aber ich sehe schon, so kommen wir nicht weiter. Lade bitte eine Mustertabelle hoch.
Gruß
Nepumuk
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 15:04:44
PeterK
Hallo Nepumuk
Ich habe die Zelle mit Unmengen von Email Addressen befüllt.
objCell.Text liefert eine String mit der Länge von 8221
objCell.Value2 leifert 20014 (!) Zeichen (den tatsächlichen String)
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 15:05:38
Heidi
Hallo Nepumuk,
ich kann leider die Firmenemails nicht hochladen. Hier ein Beispiel. So sieht es in Excel aus:
Userbild
Nur eben mit viel mehr Emails so aufgeteilt - und nach dem Makro zeigt er:
Userbild
Aber immer nur 338 Stück ....
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 15:27:31
Nepumuk
Hallo Heidi,
Peter hat mich auf meinen Fehler hingewiesen. Ich habe die falsche Eigenschaft des Cells-Objekt benutzt. Das Problem sehe ich also als gelöst an.
Jetzt bleibt nur noch die Frage, sollen doppelt Mailadressen herausgefiltert werden?
Gruß
Nepumuk
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 19:12:56
Heidi
Hallo Nepumuk,
ja sehr gerne - doppelte Einträge brauchen wir nicht.
DANKESCHÖN
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 19:24:06
Nepumuk
Hallo Heidi,
dann hoffe ich, dass das passt:
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef psa() As Any) As Long

Public Sub CopyMailAddress()
    Dim objCell As Range
    Dim strFirstAddress As String, astrMailAddress() As String
    Dim lngColumn As Long, ialngIndex As Long
    Dim objDictionary As Object
    Worksheets("Tabelle2").Rows(1).ClearContents
    With Worksheets("Tabelle1").Cells
        Set objCell = .Find(What:="@", LookIn:=xlValues, _
            LookAt:=xlPart, MatchCase:=False)
        If Not objCell Is Nothing Then
            Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
            strFirstAddress = objCell.Address
            Do
                astrMailAddress = GetMailAddress(strText:=objCell.Value2)
                If SafeArrayGetDim(astrMailAddress) > 0 Then
                    For ialngIndex = LBound(astrMailAddress) To UBound(astrMailAddress)
                        objDictionary.Item(Key:=astrMailAddress(ialngIndex)) = vbNullString
                    Next
                End If
                Set objCell = .FindNext(After:=objCell)
            Loop Until objCell.Address = strFirstAddress
            Worksheets("Tabelle2").Cells(1, 1).Resize(1, objDictionary.Count).Value = objDictionary.Keys
            Set objCell = Nothing
            Set objDictionary = Nothing
        End If
    End With
End Sub

Private Function GetMailAddress(ByVal strText As String) As String()
    Dim objRegEx As Object, objMatch As Object
    Dim astrTemp() As String
    Dim ialngIndex As Long
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .Global = True
        .Pattern = "[a-z0-9\-\.]{2,63}@[a-z0-9\-\.]{2,63}\.[a-z]{2,4}"
        .IgnoreCase = True
        Set objMatch = .Execute(strText)
    End With
    With objMatch
        If .Count > 0 Then
            Redim astrTemp(0 To .Count - 1)
            For ialngIndex = 0 To .Count - 1
                astrTemp(ialngIndex) = .Item(ialngIndex).Value
            Next
            GetMailAddress = astrTemp
        End If
    End With
    Set objRegEx = Nothing
    Set objMatch = Nothing
End Function

Gruß
Nepumuk
Anzeige
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 19:31:04
Heidi
Hallo Nepumuk,
perfekt, du hast mir sehr geholfen. TOLL!
Eine Kleinigkeit hätte ich noch, wie kann ich die Email-Adressen untereinander anzeigen lassen?
Dankeschön!
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 19:55:32
Nepumuk
Hallo Heidi,
also jetzt doch untereinander? Na gut, dann ändere diese Zeile:
Worksheets("Tabelle2").Cells(1, 1).Resize(1, objDictionary.Count).Value = objDictionary.Keys

so:
Worksheets("Tabelle2").Cells(1, 1).Resize(objDictionary.Count, 1).Value = _
    Application.Transpose(objDictionary.Keys)

Gruß
Nepumuk
AW: in Excel nur Emailadresse auslesen und kopieren
10.04.2019 19:59:04
Heidi
Hallo,
super, klappt perfekt und erleichtert mir viel Arbeit. 1000 Dank nochmal und einen schönen Abend.
Viele Grüße
Heidi

81 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige