VBA Internet suche

[Florian20]

Guten Morgen Leute,

Ich habe mal wieder ein Problem, Ich möchte gerne eine Google abfrage starten, nur klappt es nicht so wie Ich will.
Hier meine Vorstellung:

Der Code soll Google öffnen eine suche starten und die Telefonnummer Kopieren.
Mit dem "Body Text" & "Url" klapp das auch gut nur nicht mit der Tel?

Hier mein Code (ein Teil davon):

        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & Cells(i, 2) & "&Telefonnummer=" & WorksheetFunction.RandBetween(1, 10000)
        Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
        XMLHTTP.send

        Set html = CreateObject("htmlfile")
        html.body.innerHTML = XMLHTTP.ResponseText
        Set objResultDiv = html.getelementbyid("rhs_block")
        Set objH3 = objResultDiv.getelementsbytagname("span")(0)
        Set Tel = objH3.getelementsbytagname("span")(0)   'Hier wird die Telefonnummer aus dem HTML gelesen

        str_text = Replace(Tel.innerHTML, "", "")    'Hier ist der Fehler! (Laufzeitfehler '91':)
        str_text = Replace(str_text, "", "")
        Cells(i, 7) = str_text
        Cells(i, 8) = Tel.href

Ich hoffe Ihr könnt mir helfen
Lg Flo

[Käpt'n Blaubär]

Hallo,

Hier mein Code (ein Teil davon):

das ist ja fein, daß Du uns die Codezeile zeigst, in der der Code aussteigt.
Der Fehler liegt aber wahrscheinlich woanders und wirkt sich erst hier aus.

Mit anderen Worten: In Fragmenten suche ich nicht nach Fehlern.

[Florian20]

Okay hier der ganze Code:

 

Code:

Sub XMLHTTP()
    Dim url As String, lastRow As Long
    Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, Tel As Object
    Dim i As Integer
    Dim str_text As String
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    Dim cookie As String
    Dim result_cookie As String
    For i = 2 To lastRow
        url = "[url=https://www.google.co.in/search?q]https://www.google.co.in/search?q[/url]=" & Cells(i, 1) & "&Telefonnummer=" & WorksheetFunction.RandBetween(1, 10000)
        Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
        XMLHTTP.send
        Set html = CreateObject("htmlfile")
        html.body.innerHTML = XMLHTTP.ResponseText
        Set objResultDiv = html.getElementByid("rhs_block")
        Set objH3 = objResultDiv.getElementsByTagName("span")(1)
        Set Tel = objH3.getElementsByTagName("span")
        str_text = Replace(Tel.innerHTML, "<EM>", "")
        str_text = Replace(str_text, "</EM>", "")
        Cells(i, 7) = str_text
        Cells(i, 8) = Tel.href
        DoEvents
    Next
MsgBox "Alle Firmen wurden in Google geprüft!" & vbLf & _
       "Die Firmen ohne Tel und Web wurden aktualiesiert!", vbInformation, "Google Suche!"
End Sub

[Florian20]

Guten Morgen,

Ich habe den Code Nochmal umgebaut aber es geht immer noch nicht :@
Der Code sucht eine Telefonnummer aus Google und dann Laufzeitfehler"91"

Aber Ich weiß nicht warum ??

Hier der Andere Code:

Private Sub XMLTEL()
'Überprüft alle Neuen Firmen ob die Tel eingetragen wurde
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResult As Object, objrso As Object, Tel As Object
Dim i, str_text
lastRow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lastRow
        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & " " & Cells(i, 2) & " " & "Telefonnummer"
        Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.send

        Set html = CreateObject("htmlfile")
        html.body.innerhtml = XMLHTTP.ResponseText
        Set objResult = html.getElementByID("rso")
        Set objrso = objResult.getElementsByName("span")(0)   'Hier ist der Fehler!
        Set Tel = objrso.getElementsByName("span")(0)
       
        str_text = Replace(Tel.innerhtml, " ", "")
        Cells(i, 7) = "+49 " & str_text
    DoEvents
    Next i
End Sub

Hoffe nun kann mir jemand helfen
Grüße Flo

[Steffl]

Hallo Florian,

schwierig zu sagen. Vermutlich wird dir da kein Array zurückgegeben.

[Florian20]

Hallo Stefan,

Das dachte Ich mir auch schon aber in zelle "G3" also der erste durchlauf wird die Tel kopiert.
Erst beim 2 lauf kommt der Fehler.

[Steffl]

Hallo Florian,

was meinst Du mit

beim 2 lauf kommt der Fehler

Startest Du das Makro zweimal? Oder kommt der Fehler in der Zeile 3, weil die For-Schleife beginnt ja in Zeile 2? Und wenn es das zutrifft, was Unterscheidet sich bei der Internetseite bei den Einträgen?

[Florian20]

Hi nochmal,

Ja genau wenn die For schleife anfängt. Dann kommt der Fehler in der Zeile beim öffnen vom ("span") Dialog.
Das Ist dann die Telefonnummer und soweit Ich weiß gibt es keinen unterschied da Google geöffnet wird.

Und Google sollte doch immer gleich sein oder?

Ps. wenn die For schleife 1 mal läuft dann geht es beim 2 mal hängt es ???

[Steffl]

Hallo Florian,

was ist eigentlich getElementsByName? Und versuche es mal so (ist aber ungetestet)

Code:

Private Sub XMLTEL()
'Überprüft alle Neuen Firmen ob die Tel eingetragen wurde
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResult As Object, objrso As Object, Tel As Object
Dim i, str_text
lastRow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lastRow
        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & " " & Cells(i, 2) & " " & "Telefonnummer"
        Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.send

        Set html = CreateObject("htmlfile")
        html.body.innerhtml = XMLHTTP.ResponseText
        Set objResult = html.getElementByID("rso")
        If IsArray(objResult.getElementsByName("span")) Then
            Set objrso = objResult.getElementsByName("span")(0)   'Hier ist der Fehler!
            Set Tel = objrso.getElementsByName("span")(0)
        Else
            Set objrso = objResult.getElementsByName("span")   'Hier ist der Fehler!
            Set Tel = objrso.getElementsByName("span")
        End If
        str_text = Replace(Tel.innerhtml, " ", "")
        Cells(i, 7) = "+49 " & str_text
    DoEvents
    Next i
End Sub

[Florian20]

Also Ich habe so getestet es geht auch so nicht.

das getElementByTagName oder getElementsByName usw. ist aus der HTML Programmiersprache

Hier ein Bild von Google die gelben Sachen ruft das getElement auf.
Die (0) Steht für den Wert also welchen Wert getElement suchen soll.
In der Zeile ("span") währe (0) = ("span")

Lg Flo