Clever-Excel-Forum

Hallo Zusammen,
kurz vorab: Ich habe früher (10 Jahre) als Anfänger viel mit VBA gemacht. In der Zwischenzeit weniger. Daher eingerostet.

Ich habe folgende Herausforderung:
In den Zellen A1:A2000, stehen eine URL (Websites)
Ich möchte nun alle Emails (mailto) finden und in die Zellen B1 ff schreiben.

Geht dies überhaupt? Kann im Netz nicht wirklich etwas finden.

Danke für euren Input

Stefan

Hallo!

Das geht mit "Ersetzen".

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B
1	mailto:beispiel@beispiel.org	beispiel@beispiel.org

Zelle	Formel
B1	=ERSETZEN(A1;1;7;"")

Gruß, René

Danke für deine Antwort.

Ich habe es vermutlich nicht richtig erklärt:
In der Zelle A1:A2000 stehen jeweils URL = http//www.xxxxx.de.

Soweit ich noch weiß kkann man irgendwie den Quellcode in die Zwischenablage lesen und dann nach Email Adressen durchsuchen. hierfür nutzt man dann "mailto" für die Suche und nicht etwa das "@"-Zeichen.

Ich kann dies nur nicht mehr in VBA übersetzen. Ist zu lange her... :

Hallo,

z. B. so:

Code:
Option Explicit

Public Sub Main()

    Dim objHTTPRequest As Object

    Dim strResult As String

    Dim strText As String

    Dim lngRow As Long

    On Error GoTo Fin

    Set objHTTPRequest = CreateObject("WinHTTP.WinHTTPrequest.5.1")

    objHTTPRequest.SetTimeouts 3000, 3000, 3000, 3000

    With ThisWorkbook.Worksheets("Tabelle1")

        For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row

            objHTTPRequest.Open "GET", .Cells(lngRow, 1).Text, False

            objHTTPRequest.Send

            If objHTTPRequest.Status = 200 Then

                strText = objHTTPRequest.ResponseText

                strResult = fncMail(strText)

                If Trim$(strResult) = "" Then

                    strResult = "Keine Mailadresse!"

                Else

                    .Cells(lngRow, 2).Value = strResult

                End If

            Else

                strResult = "Keine Antwort!"

            End If

        Next lngRow

    End With

Fin:

    Set objHTTPRequest = Nothing

    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description

End Sub

Private Function fncMail(ByVal strAll As String) As String

    Dim objRegEXP As Object

    Dim objMs As Object

    Dim objM As Object

    Dim strEmailAddress As String

    Set objRegEXP = CreateObject("VBScript.RegExp")

    With objRegEXP

        .Pattern = "([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})"

        .IgnoreCase = True

        .Global = True

        Set objMs = .Execute(strAll)

        If objMs.Count > 0 Then

            fncMail = objMs.Item(0).Value

        End If

    End With

    Set objM = Nothing

    Set objMs = Nothing

End Function

Super, Danke.
Werde ich Morgen direkt ausprobieren!

Hallo,

der Code funktioniert bedingt!

> Homepages von bestimmten Anbietern (z.B. Wix.com) werden nicht "richtig" ausgelesen.
Hier taucht immer eine Platzhalter Email auf: "14370afcdc17429f9e418d5ffbd0334a@sentry.wixpress.com"
Im Impressum steht aber eine echte: info@musterfirma.de

> Bei anderen Hompages wird gar nichts gefunden
Im Impressum steht aber eine echte: info@musterfirma.de

> Diverse Fehlermeldungen zwingen zum Neustart
[
Bild bitte so als Datei hochladen: Klick mich!
]

[color=#333333][size=small][font=Tahoma, Verdana, Arial, sans-serif]Für ca. 50 % konnte ich eine Email per VBA finden.

Dies ist schon eine riesige Erleichterung.

Danke dafür.

Vielleicht gibt es ja noch weitere Optimierungsmöglichkeiten. zum Beispiel ALLE Emails einer URL finden!

Danke

Hallo,

nun - das ist klar. Je nachdem, wie die Seite aufgebaut ist, musst du entsprechend reagieren. Jetzt kommt die Fleißarbeit.

Etwas bequemer hast du es mit PowerShell. Da bläkt allerdings gerne der Virenscanner.

Nehmen wir mal dein Beispiel "Wix.com".

Mit...

Code:
varArr = Split(CreateObject("wscript.shell").exec("PowerShell (iwr ""https://de.wix.com"").links.href").stdout.readall, vbCrLf)

... erhältst du ein Array mit allen Links der Seite. Unter Anderem auch "https://de.wix.com/impressum"

Mit...

Code:
varArr = Split(CreateObject("wscript.shell").exec("PowerShell (iwr ""https://de.wix.com/impressum"").links.href").stdout.readall, vbCrLf)

... dann auch "mailto:support@wix.com".

Jetzt noch eine Schleife um deine Seiten und fertig.

Das lässt sich, mit Anpassungen, auch mit dem "WinHTTPrequest" machen.

Hallo Case,

Danke für deine Antwort.
Ich habe mich mal wieder missverständlich ausgedrückt! Huh

Das Beispiel bezog sich auf Service-Anbieter Wixpress mit dem einige Ihre Webseiten aufbauen. Hier findet der Code immer nur den Platzhalter des Anbieters.

Ich kann mir vorstellen, dass deine Lösung bei meinen restlichen Adressen funktioniert. Denn hier wird auch kein Ergebnis ausgegeben. (siehe PN)

Nur habe ich keine Ahnung wo ich deinen Vorschlag im Code einbinden kann/soll. Confused

Wie gesagt: Ich taste mich nach vielen Jahren erst wieder an VBA ran. Und ehrlicherweise waren meine damaligen Versuche einfacher und nur innerhalb von Excel.

Deinen Code kann ich, trotz Einzelschritt, nur zu einem Bruchteil interpretieren.
Mir scheinen auch noch kleine Fehler in den Schleifen (habe ich angepasst) und nicht genutzte Variablen vorhanden zu sein. Idea

Ich würde mich freuen wenn du mir noch mal in die Spur helfen könntest.

Danke

stepcke

mumpel

stepcke

Case

stepcke

stepcke

Case

stepcke