Goggle'de sıra bulucu

[mozdem]

Sub xmlHttp()

    Dim URl As String, lastRow As Long
    Dim xmlHttp As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object


    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To lastRow

   
        URl = "https://www.google.com.tr/search?q=" & Cells(i, 1)
        
        Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
        xmlHttp.Open "GET", URl, False
        xmlHttp.setRequestHeader "Content-Type", "text/xml"
        xmlHttp.send

        Set html = CreateObject("htmlfile")
        html.body.innerHTML = xmlHttp.ResponseText
        Set objResultDiv = html.getelementbyid("rso")
        Set objH3 = objResultDiv.getelementsbytagname("H3")(0)
        Set link = objH3.getelementsbytagname("a")(0)


        str_text = Replace(link.innerHTML, "<EM>", "")
        str_text = Replace(str_text, "</EM>", "")

        Cells(i, 2) = str_text
        Cells(i, 3) = link.href
    Next
End Sub

Ek dosyada da görüldüğü gibi aranan bir kelimeyi googlede arayıp 1. sıradaki veriyi excelde gösteriyor.

İstediğim aranan veri örneğin "excel" kelimesini arattırdığımda "excel.web.tr" linki kaçıncı sırada. bunu bulabilir miyim.
Teşekkürler.

 

[Zeki Gürsoy]

Regexp, bu işlem için uygun görünüyor. Alınacak site bilgisi de "<cite>" tag' ında bulunuyor.

Kolay gelsin...

 

[mozdem]

Regexp, bu işlem için uygun görünüyor. Alınacak site bilgisi de "<cite>" tag' ında bulunuyor.

Kolay gelsin...

hocam, Araştırdım, yapamadım. Zaman ayırabilirseniz sevinirim.

 

[mozdem]

//Güncel
Yardımlarınızı bekliyorum

 

[Zeki Gürsoy]

Merhaba,

Verdiğiniz kodu güncelledim...

Sub xmlHttp()
    Dim URl As String, lastRow As Long
    Dim xmlHttp As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    Dim reg As Object, ms As Object, m As Object
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To lastRow
   
        URl = "https://www.google.com.tr/search?q=" & Cells(i, 1)
        
        Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
        xmlHttp.Open "GET", URl, False
        xmlHttp.setRequestHeader "Content-Type", "text/xml"
        xmlHttp.send

        [COLOR=Blue][B]Set reg = CreateObject("vbscript.regexp")
        reg.Global = True
        reg.Pattern = "<cite>(.+?)</cite>"
        
        Set ms = reg.Execute(xmlHttp.ResponseText)
        
        For Each m In ms
            Debug.Print Replace(Replace(m.submatches(0), "<b>", ""), "</b>", "")
        Next[/B][/COLOR]
        
    Next
End Sub

 

[mozdem]

Merhaba,

Verdiğiniz kodu güncelledim...

Sub xmlHttp()
    Dim URl As String, lastRow As Long
    Dim xmlHttp As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    Dim reg As Object, ms As Object, m As Object
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To lastRow
   
        URl = "https://www.google.com.tr/search?q=" & Cells(i, 1)
        
        Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
        xmlHttp.Open "GET", URl, False
        xmlHttp.setRequestHeader "Content-Type", "text/xml"
        xmlHttp.send

        [COLOR=Blue][B]Set reg = CreateObject("vbscript.regexp")
        reg.Global = True
        reg.Pattern = "<cite>(.+?)</cite>"
        
        Set ms = reg.Execute(xmlHttp.ResponseText)
        
        For Each m In ms
            Debug.Print Replace(Replace(m.submatches(0), "<b>", ""), "</b>", "")
        Next[/B][/COLOR]
        
    Next
End Sub

Hocam ,cevap verdiğiniz için teşekkür ederim.
Ancak, ben kodu çalıştıramadım.
Yardımlarınızı bekliyorum.

 

[Zeki Gürsoy]

Aslında kod çalışıyor da, sonuçları editör penceresine yazdırmıştım. Aşağıdaki gibi deneyin...

Sub xmlHttp()
    Dim URl As String, lastRow As Long
    Dim xmlHttp As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    Dim reg As Object, ms As Object, m As Object
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To lastRow
   
        URl = "https://www.google.com.tr/search?q=" & Cells(i, 1)
        
        Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
        xmlHttp.Open "GET", URl, False
        xmlHttp.setRequestHeader "Content-Type", "text/xml"
        xmlHttp.send

        Set reg = CreateObject("vbscript.regexp")
        reg.Global = True
        reg.Pattern = "<cite>(.+?)</cite>"
        
        Set ms = reg.Execute(xmlHttp.ResponseText)
        
        s = 1
        
        For Each m In ms
            s = s + 1
            Cells(i, s) = Replace(Replace(m.submatches(0), "<b>", ""), "</b>", "")
        Next
        
    Next
End Sub

 

[mozdem]

Aslında kod çalışıyor da, sonuçları editör penceresine yazdırmıştım. Aşağıdaki gibi deneyin...

Sub xmlHttp()
    Dim URl As String, lastRow As Long
    Dim xmlHttp As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    Dim reg As Object, ms As Object, m As Object
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To lastRow
   
        URl = "https://www.google.com.tr/search?q=" & Cells(i, 1)
        
        Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
        xmlHttp.Open "GET", URl, False
        xmlHttp.setRequestHeader "Content-Type", "text/xml"
        xmlHttp.send

        Set reg = CreateObject("vbscript.regexp")
        reg.Global = True
        reg.Pattern = "<cite>(.+?)</cite>"
        
        Set ms = reg.Execute(xmlHttp.ResponseText)
        
        s = 1
        
        For Each m In ms
            s = s + 1
            Cells(i, s) = Replace(Replace(m.submatches(0), "<b>", ""), "</b>", "")
        Next
        
    Next
End Sub

Hocam, Çok teşekkür ederim ellerinize sağlık.

 

[Faruk CETİNKAYA]

hala calısıyor mu acaba

 

[Faruk CETİNKAYA]

hocam banada lazım kodu ekledım ama birsey olmadı

 

[assenucler]

Sayın mozdem,

Öncelikle iyi bayramlar.

Açtığınız konu çok ilgimi çekti.
Rica etsem dosyanın son halini eklemeniz mümkün mü?

Yardımınız için önceden teşekkürler.

 

[Faruk CETİNKAYA]

Nasıl sevaba girersiniz şu mübarek bayram

 

[Haluk]

Bu iş artık o metotla yapılamıyor.... Google'ın bu iş için hazırladığı API'yi kullanarak verileri JSON formatında alabilirsiniz...

Detaylar, aşağıdaki linkte;

Custom Search JSON API: Introduction | Programmable Search Engine | Google for Developers

developers.google.com

.

 

[assenucler]

Sayın Haluk,


Değerli üstadım, öncelikle Kurban Bayramı'nızı kutlar; sağlık, afiyet, huzur, mutluluk ve bol kazançlar dilerim.
Bilgilendirmeniz için teşekkürler.

Saygılar,
Selim

 

[Faruk CETİNKAYA]

Teşekkür ederim