Search a word from Excel and bring its Keyword and URL using VBA.

[Muhamed Faizal]

Hi,

I got the following code from one of the website and tried to test it. it works on my personal laptop however the same is not working on my office computer. I get following error. could you please check and let me know what is the real problem is and howcome I overcome it?

Home : Vista, MS Excel 2007
Office : Windows8, Office 2010

Please let me know that if you have any question.

Following are my requirement

Cell A2 onward contain the words I want to search in google by the VBA code and returns the results in Cell B2 and corresponding URL to C2

	A</SPAN>	B</SPAN>	C</SPAN>
1</SPAN>	Search Word</SPAN>	Key word</SPAN>	URL</SPAN>
2</SPAN>	Muhamed Faizal, Linkedin</SPAN>
3</SPAN>	EXL Services</SPAN>

<TBODY>
</TBODY>

Error I Get
Run-time error '-2147012867 (80072efd)':
A connection with the server could not be established

Code:

Sub SearchKeyword()
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 ' I get error here

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, "", "")
str_text = Replace(str_text, "", "")

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

 

[iliauk]

This worked for me:

Dim i As Integer
Dim str_text As String
Dim url As String
Dim LastRow As Long
Dim XMLHTTP As Object
Dim html As Object
Dim objResultDiv As Object
Dim objH3 As Object
Dim link As Object
Dim dtTimer As Date
Dim lAddtime As Date


Cells(1, 1) = "Enter:"
Cells(1, 2) = "Key Word"
Cells(1, 3) = "URL"


LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
url = "https://www.google.co.uk/search?q=" & Cells(i, 1)
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"

dtTimer = Now
lAddtime = TimeValue("00:00:20")
Do Until XMLHTTP.ReadyState = 1
DoEvents
If dtTimer + lAddtime > Now Then Exit Do
Loop


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, "", "")
str_text = Split(Split(str_text, "<EM>")(1), "</EM>")(0)

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

 

[Crystal69]

Hi,

I used this code which worked great, it did 954 searches then crashed giving the message 'Object variable or with block variable not set.' on line et objH3 = objResultDiv.getElementsByTagName("H3")(0).

Any ideas????

I've even tried to start again going over ones already done but it crashes in the same place on the first search.