• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Goggle'de sıra bulucu

M

mozdem

Altın Üye
Katılım
11 Kasım 2005
Mesajlar
454
Excel Vers. ve Dili
Windows 2011 TR
MS Office 365 TR - 64bit

VBA, Selenium ve VBS
Kod: 
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.
 

Ekli dosyalar

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

Kolay gelsin...
 
//Güncel
Yardımlarınızı bekliyorum
 
Merhaba,

Verdiğiniz kodu güncelledim...

Kod: 
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
 
Zeki Gürsoy' Alıntı:
Merhaba,

Verdiğiniz kodu güncelledim...

Kod: 
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
Genişletmek için tıkla ...

Hocam ,cevap verdiğiniz için teşekkür ederim.
Ancak, ben kodu çalıştıramadım.
Yardımlarınızı bekliyorum.
 
Son düzenleme:
Aslında kod çalışıyor da, sonuçları editör penceresine yazdırmıştım. Aşağıdaki gibi deneyin...

Kod: 
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
 
Zeki Gürsoy' Alıntı:
Aslında kod çalışıyor da, sonuçları editör penceresine yazdırmıştım. Aşağıdaki gibi deneyin...

Kod: 
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
Genişletmek için tıkla ...


Hocam, Çok teşekkür ederim ellerinize sağlık.
 
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.
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst