اصلاح كد جستجوي ليستي از كليد واژه ها توسط گوگل به كمك اكسل. اساتيد حرفه اي كمك كنن!

[afshin3a]

سلام بر اساتيد گرامي
كدي كه در زير معرفي مي كنم، ليستي از كليد واژه هاي شما را در گوگل جستجو مي كند و لينك و عنوان تاپ ليست (اولين ركورد جستجو) را بر مي گرداند.

 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 start_time As Date
    Dim end_time As Date

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

    Dim cookie As String
    Dim result_cookie As String

    start_time = Time
    Debug.Print "start_time:" & start_time

    For i = 2 To lastRow

        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&rnd=" & 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("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
        DoEvents
    Next

    end_time = Time
    Debug.Print "end_time:" & end_time

    Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
    MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub

enter image description here 

اين كد يك مشكل بزرگ دارد. آن هم اينست كه اگر كليد واژه اي در گوگل موجود نباشد، خطا مي دهد و عمليات جستجو را متوقف مي كند. كسي از اساتيد هست كه بتواند اين كد را اصلاح كند؟
به عنوان مثال در فايل پيوست تا رديف 4 را به خوبي جستجو مي كند و به رديف 5 كه مي رسد، عمليات جستجو متوقف مي شود (چون اگر واژه sdassdaddsdasdda را در گوگل سرچ كنيد، نتيجه اي در بر ندارد.). حالا ميخواهيم كد به شيوه اي اصلاح شود كه اگر واژه اي در گوگل جستجو شد و نتيجه اي در بر نداشت، در ستون B2 و جلوي همون واژه بنويسه كه مثلا No information availble و عمليات جستجو ادامه پيدا كند.

اطلاعات بيشتر در لينك زير:
http://stackoverflow.com/questions/1...k-of-the-first

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[iranweld]

با سلام

کد ذیل را بالای خطوط اول کدهای ماکرو خود اضافه کنید

On Error Resume Next 

[afshin3a]

ممنون از پاسختون. كد را اضافه كردم ولي يه مشكل داره هنوز. به جاي اينكه مقدار "سلولي كه در جستجوي گوگل بدون نتيجه است"، خالي باشد، مقدار سلول بالاتر را اخذ مي كند.
حداقل بايد خالي باشد. يا مثلا جلوي همون سلول بنويسه No information available.

[Ali Parsaei]

سلام،
البته من خيلي کدتان را متوجه نشدم و زياد وارد نيستم، ولي علي الحساب يک کلکي زدم تا کارتان راه بيافتد، ولي اصولي نيست،
حواستان باشد ديگر عبارت

ACEDIUM ACETHYLO SALICYLICIUM جزو مواردي نيست که گوگل يافت نکند! چون آن را در اين سايت نوشته ايد! پس يک چيز ديگر به کار ببريد
کد را به صورت زير تغيير دهيد:

Sub XMLHTTP()
    Application.ScreenUpdating = False
    On Error Resume Next
    Dim url As String, lastRow As Long
    Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
    Dim start_time As Date
    Dim end_time As Date

    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    Dim cookie As String
    Dim result_cookie As String
    
    start_time = Time
    Debug.Print "start_time:" & start_time

    For i = 2 To lastRow

        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&rnd=" & 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("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
        DoEvents
    Next
    
    end_time = Time
    Debug.Print "end_time:" & end_time
    
    Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
    Dim c As Range
    For Each c In Range("c2:c" & lastRow)
    If c.Value = "" Then
    c.Offset(0, -1).Value = "No information available"
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub