Excel Macro to Count Google Search Results

Hi, it looks like the Google search URL has changed since then.  Try this

Public Sub ExcelGoogleSearch()
    Dim searchwords As String
    Dim search_url As String
    Dim search_http As Object
    Dim results_var As String, NumberOfResults As Variant
    Dim rowcount As Long
    Dim pos_1 As Long, pos_2 As Long, pos_3 As Long
    With Sheets("Sheet1")
        .Columns(2).ClearContents
        rowcount = 1
        Do While .Range("A" & rowcount) <> ""
            searchwords = .Range("A" & rowcount).Value
            ' Get keywords and validate by adding + for spaces between
            searchwords = Replace$(searchwords, " ", "+")
            ' Obtain the source code for the Google-searchterm webpage
            'https://www.google.com.au/#hl=en&output=search&q=my+custom+search&oq=my+custom+search
            search_url = "http://www.google.com/search?hl=en&output=search&q=" & searchwords & "&oq=" & searchwords
            Set search_http = CreateObject("MSXML2.XMLHTTP")
            search_http.Open "GET", search_url, False
            search_http.Send
            results_var = CStr(search_http.ResponseText)
            Set search_http = Nothing
            ' Find the number of results and post to sheet
            pos_1 = InStr(results_var, "<div id=resultStats>")
            If pos_1 > 0 Then
                pos_1 = pos_1 + 20
                pos_2 = InStr(3 + pos_1, results_var, "<no", vbTextCompare) - 1
                NumberOfResults = Mid(results_var, pos_1, pos_2 - pos_1 + 1)
                MsgBox NumberOfResults
                Range("B" & rowcount) = NumberOfResults
            Else
                Range("B" & rowcount) = "UNKNOWN"
            End If
            rowcount = rowcount + 1
        Loop
    End With
End Sub

Select allOpen in new window

Regards,

Rob.

Before you go any further with this project, you should go do your search in your browser manually and save the source of the page you get.  Then see if you can find any of the things you want in that code.

What you are trying to do is actually against Google's Terms of Service.  They have started making it difficult to 'scrape' their pages for anything.  Most of the code you will see in a Google search results page is javascript that is used to display the results.

@RobSampson

I tried your code and still receive the same debug error:

Run-time error '-2147024891 (80070005)':
Access is denied

Can you try turning off IE9 Protected Mode?  Is the Excel workbook on your C Drive?

Rob.

@RobSampson

I put the Excel file on my C drive
I turned off IE9 Protected mode

I get the same error.

I tested on Win 7, without UAC enabled, Excel 2007 with IE8, and it works.  I'll see if I can with IE9 early next week.

Rob.

I've now tested in Win 7 with IE9 Protected mode Off, and UAC on Default, and it works for me.  Are you using a Windows 7 workstation?

What line is the error on now?

Can you run excel.exe by SHIFT + right clicking it, then "Run As Administrator", then load the file?

Rob.

UAC was disabled
I tried using Excel 2007
I tried from a different computer. once with W7 Ultimate, the other from W7 Home
I put the Excel file on my C drive
I turned off IE9 Protected mode

Debug error is line:
search_http.Send

Odd, above this line:
search_http.Open "GET", search_url, False

can you put this:
InputBox "URL:", "URL", search_url

and then when the URL apears in the input box, copy and paste it into IE, and see if it resolves.  Otherwise, do a simple search manually in Google, and post it's resultant URL here for me to see.

Regards,

Rob.

Yes, it resolves to https.  The code had http.

I changed the code to https and now it works.

However, I just want the result to be inputted into the spreadsheet.

What I get is a box that pops up showing me the results, then I have to click OK, then it puts the value into the spreadsheet, then it loops to the next one.  

Secondly, how to I get rid of the "About " and " results"?  I just want the # to appear in the results column.

If I put the values from column A into quotes, like, "how to make small seats smaller" the result does not have the word "about." So I just want the integers to display in columbn B, not words.

To eliminate the message box that pops up with the results just change this line

MsgBox NumberOfResults

into this line

' MsgBox NumberOfResults

You can change these two lines:

                MsgBox NumberOfResults
                Range("B" & rowcount) = NumberOfResults

Select allOpen in new window

to this:

                'MsgBox NumberOfResults
                Range("B" & rowcount) = Replace(Replace(NumberOfResults, "About ", ""), " results", "")

Select allOpen in new window

Regards,

Rob.

One last thing, if I want the search term to be in quotes like
"how to make small seats smaller"

instead of
how to make small seats smaller

How can I make this a default in the code as opposed to just putting quotes around the words in column A?

Sure, change this:

            searchwords = Replace$(searchwords, " ", "+")

Select allOpen in new window

to this:

            searchwords = Replace$(searchwords, " ", "+")
            If Left(searchwords, 1) <> """" Then searchwords = """" & searchwords
            If Right(searchwords, 1) <> """" Then searchwords = searchwords & """"

Select allOpen in new window

Regards,

Rob.

What would the change be to this line;

Range("B" & rowcount) = Replace(Replace(NumberOfResults, "About ", ""), " results", "")

Select allOpen in new window

if I also wanted to add " result" too?  This would be needed when there is 1 result.

It would have to be changed to this:

Range("B" & rowcount) = Replace(Replace(Replace(NumberOfResults, "About ", ""), " results", ""), " result", "")

Select allOpen in new window

Right now, if there is a phrase in column A with "&" the results with the quotes are not correct.  Here's an example:

"small animals & big birds go home" should return 0, instead it's returning 291,000,000  How can this be fixed?

The example with the "&" and the results using the NO quotes is also returning incorrect results.  It should be 51,300,000 and it is also returning 291,000,000. How can this be fixed?

This would remove " result" as well:
Range("B" & rowcount) = Replace(Replace(Replace(NumberOfResults, "About ", ""), " results", ""), " result", "")

To change "UNKNOWN" to 0, change
                Range("B" & rowcount) = "UNKNOWN"

to
                Range("B" & rowcount) = "0"

Rob.

Right now, if there is a phrase in column A with "&" the results with the quotes are not correct.  Here's an example:

"small animals & big birds go home" should return 0, instead it's returning 291,000,000  How can this be fixed?

The example with the "&" and the results using the NO quotes is also returning incorrect results.  It should be 51,300,000 and it is also returning 291,000,000. How can this be fixed?

OK, add this function to the bottom of the code:

Function URLEncode(strURLString)
	' TITLE: URLEncode
	' DESCRIPTION: This function will modify a string into a URL friendly string
	'	by replacing URL invalid characters with the equivalent hex codes.
	' INPUT:
	'	strURLString contains a string that is to be encoded into a URL friendly string
	' OUTPUT:
	'	A string value that is the string encoded with the hex codes for the invalid characters
	strTemp = ""
	strChar = ""
	For intPos = 1 To Len(strURLString)
		intASCII = Asc(Mid(strURLString, intPos, 1))
		If intASCII = 32 Then
			strTemp = strTemp & "%20"
		ElseIf ((intASCII < 123) And (intASCII > 96)) Then
			strTemp = strTemp & Chr(intASCII)
		ElseIf ((intASCII < 91) And (intASCII > 64)) Then
			strTemp = strTemp & Chr(intASCII)
		ElseIf ((intASCII < 58) And (intASCII > 47)) Then
			strTemp = strTemp & Chr(intASCII)
		Else
			strChar = Trim(Hex(intASCII))
			If intASCII < 16 Then
				strTemp = strTemp & "%0" & strChar
			Else
				strTemp = strTemp & "%" & strChar
			End If
		End If
	Next
	URLEncode = strTemp
End Function

Select allOpen in new window

Then change this line:
            search_url = "http://www.google.com/search?hl=en&output=search&q=" & searchwords & "&oq=" & searchwords


to this:
            search_url = "http://www.google.com/search?hl=en&output=search&q=" & searchwords & "&oq=" & URLEncode(searchwords)

and see how that goes.

Rob.

Compile Error:
URLEncode
Sub or Function Not Defined

The "&" needs to be changed to "%26" in the search phrase.  How do you do this?

I think I just solved this.  Did I do this right, or will this screw something else up?

searchwords = Replace(Replace$(searchwords, " ", "+"), "&", "%26")

Why is the $ there?  Does it need to be in the first Replace too?

Before you got this error:
Compile Error:
URLEncode
Sub or Function Not Defined

did you copy and paste the URLEncode function from comment ID: 38076992 into your script?

It will do the encoding for you.

The $ does not need to be on the Replace function.  That was legacy notation.

Regards,

Rob.

I missed the code in post 38076992

So in this code

Public Sub ExcelGooglePHRASESearch()
    Dim searchwords As String
    Dim search_url As String
    Dim search_http As Object
    Dim results_var As String, NumberOfResults As Variant
    Dim rowcount As Long
    Dim pos_1 As Long, pos_2 As Long, pos_3 As Long
    With Sheets("Sheet1")
        .Columns(2).ClearContents
        rowcount = 1
        Do While .Range("A" & rowcount) <> ""
            searchwords = .Range("A" & rowcount).Value
            ' Get keywords and validate by adding + for spaces between
            ' Broad Search
            '    searchwords = Replace(searchwords, " ", "+")
            ' Phrase Search
            searchwords = Replace(searchwords, " ", "+")
            If Left(searchwords, 1) <> """" Then searchwords = """" & searchwords
            If Right(searchwords, 1) <> """" Then searchwords = searchwords & """"
            ' Obtain the source code for the Google-searchterm webpage
            'https://www.google.com.au/#hl=en&output=search&q=my+custom+search&oq=my+custom+search
            search_url = "https://www.google.com/search?hl=en&output=search&q=" & searchwords & "&oq=" & URLEncode(searchwords)
            Set search_http = CreateObject("MSXML2.XMLHTTP")
            'InputBox "URL:", "URL", search_url
            search_http.Open "GET", search_url, False
            search_http.send
            results_var = CStr(search_http.responsetext)
            Set search_http = Nothing
            ' Find the number of results and post to sheet
            pos_1 = InStr(results_var, "<div id=resultStats>")
            If pos_1 > 0 Then
                pos_1 = pos_1 + 20
                pos_2 = InStr(3 + pos_1, results_var, "<no", vbTextCompare) - 1
                NumberOfResults = Mid(results_var, pos_1, pos_2 - pos_1 + 1)
                ' MsgBox NumberOfResults
                Range("B" & rowcount) = Replace(Replace(Replace(NumberOfResults, "About ", ""), " results", ""), " result", "")
            Else
                Range("B" & rowcount) = "0"
            End If
            rowcount = rowcount + 1
        Loop
    End With
End Sub

Select allOpen in new window

Where does this code go in?

Function URLEncode(strURLString)
	' TITLE: URLEncode
	' DESCRIPTION: This function will modify a string into a URL friendly string
	'	by replacing URL invalid characters with the equivalent hex codes.
	' INPUT:
	'	strURLString contains a string that is to be encoded into a URL friendly string
	' OUTPUT:
	'	A string value that is the string encoded with the hex codes for the invalid characters
	strTemp = ""
	strChar = ""
	For intPos = 1 To Len(strURLString)
		intASCII = Asc(Mid(strURLString, intPos, 1))
		If intASCII = 32 Then
			strTemp = strTemp & "%20"
		ElseIf ((intASCII < 123) And (intASCII > 96)) Then
			strTemp = strTemp & Chr(intASCII)
		ElseIf ((intASCII < 91) And (intASCII > 64)) Then
			strTemp = strTemp & Chr(intASCII)
		ElseIf ((intASCII < 58) And (intASCII > 47)) Then
			strTemp = strTemp & Chr(intASCII)
		Else
			strChar = Trim(Hex(intASCII))
			If intASCII < 16 Then
				strTemp = strTemp & "%0" & strChar
			Else
				strTemp = strTemp & "%" & strChar
			End If
		End If
	Next
	URLEncode = strTemp
End Function

Select allOpen in new window

You can put functions at the bottom, as I have done here:

Public Sub ExcelGooglePHRASESearch()
    Dim searchwords As String
    Dim search_url As String
    Dim search_http As Object
    Dim results_var As String, NumberOfResults As Variant
    Dim rowcount As Long
    Dim pos_1 As Long, pos_2 As Long, pos_3 As Long
    With Sheets("Sheet1")
        .Columns(2).ClearContents
        rowcount = 1
        Do While .Range("A" & rowcount) <> ""
            searchwords = .Range("A" & rowcount).Value
            ' Get keywords and validate by adding + for spaces between
            ' Broad Search
            '    searchwords = Replace(searchwords, " ", "+")
            ' Phrase Search
            searchwords = Replace(searchwords, " ", "+")
            If Left(searchwords, 1) <> """" Then searchwords = """" & searchwords
            If Right(searchwords, 1) <> """" Then searchwords = searchwords & """"
            ' Obtain the source code for the Google-searchterm webpage
            'https://www.google.com.au/#hl=en&output=search&q=my+custom+search&oq=my+custom+search
            search_url = "https://www.google.com/search?hl=en&output=search&q=" & searchwords & "&oq=" & URLEncode(searchwords)
            Set search_http = CreateObject("MSXML2.XMLHTTP")
            'InputBox "URL:", "URL", search_url
            search_http.Open "GET", search_url, False
            search_http.send
            results_var = CStr(search_http.responsetext)
            Set search_http = Nothing
            ' Find the number of results and post to sheet
            pos_1 = InStr(results_var, "<div id=resultStats>")
            If pos_1 > 0 Then
                pos_1 = pos_1 + 20
                pos_2 = InStr(3 + pos_1, results_var, "<no", vbTextCompare) - 1
                NumberOfResults = Mid(results_var, pos_1, pos_2 - pos_1 + 1)
                ' MsgBox NumberOfResults
                Range("B" & rowcount) = Replace(Replace(Replace(NumberOfResults, "About ", ""), " results", ""), " result", "")
            Else
                Range("B" & rowcount) = "0"
            End If
            rowcount = rowcount + 1
        Loop
    End With
End Sub

Function URLEncode(strURLString)
	' TITLE: URLEncode
	' DESCRIPTION: This function will modify a string into a URL friendly string
	'	by replacing URL invalid characters with the equivalent hex codes.
	' INPUT:
	'	strURLString contains a string that is to be encoded into a URL friendly string
	' OUTPUT:
	'	A string value that is the string encoded with the hex codes for the invalid characters
	strTemp = ""
	strChar = ""
	For intPos = 1 To Len(strURLString)
		intASCII = Asc(Mid(strURLString, intPos, 1))
		If intASCII = 32 Then
			strTemp = strTemp & "%20"
		ElseIf ((intASCII < 123) And (intASCII > 96)) Then
			strTemp = strTemp & Chr(intASCII)
		ElseIf ((intASCII < 91) And (intASCII > 64)) Then
			strTemp = strTemp & Chr(intASCII)
		ElseIf ((intASCII < 58) And (intASCII > 47)) Then
			strTemp = strTemp & Chr(intASCII)
		Else
			strChar = Trim(Hex(intASCII))
			If intASCII < 16 Then
				strTemp = strTemp & "%0" & strChar
			Else
				strTemp = strTemp & "%" & strChar
			End If
		End If
	Next
	URLEncode = strTemp
End Function

Select allOpen in new window

Just had to make one small tweak:

change this

search_url = "https://www.google.com/search?hl=en&output=search&q=" & searchwords & "&oq=" & URLEncode(searchwords)

Select allOpen in new window

to this:

search_url = "https://www.google.com/search?hl=en&output=search&q=" & URLEncode(searchwords) & "&oq=" & URLEncode(searchwords)

Select allOpen in new window

Thanks man!

post the new code with my last change so I can give you points!

Thanks for grade and the points.  Let me know if you need any other assistance.

Regards,

Rob.

Can I get an updated answer to this please?

I'm using Excel 2011 for Mac, Version 14.3.8

This is the line that always gets highlighted:

Set search_http = CreateObject("MSXML2.XMLHTTP")

It gives the message:

"Run-Time Error 429: ActiveX component can't create object"

Thank you!

Hi, I'm not familiar with Mac systems, but ActiveX controls are Windows only, and as far as I know there is no alternative.  The only thing I can find is that you could write a web query for Excel that may come close to what you need:
http://support.microsoft.com/default.aspx?scid=kb;en-us;274787

Rob.

Just to clarify, the only reason it's not working is that I'm on a Mac?

Thank you for the article, definitely helps!

It's certainly a definite reason why it's not working, since the ActiveX error is going to occur on Mac. Having said that, since this script is nearly two years old, there's a chance it may not work quite right, since Google have been known to change things over the years....

Rob.

Ok, just got a chance to test it out. It all goes through correctly, but the results all come up as 0 when they shouldn't. Any thoughts?

I'll have to test it out and debug it. Hopefully I can do that in the next day or two...

Hi, I think I needed just to make a very slight change to the responseText parsing, so this has worked for me, in Excel 2007 on Windows 7.

Rob.

Public Sub ExcelGooglePHRASESearch()
    Dim searchwords As String
    Dim search_url As String
    Dim search_http As Object
    Dim results_var As String, NumberOfResults As Variant
    Dim rowcount As Long
    Dim pos_1 As Long, pos_2 As Long, pos_3 As Long
    With Sheets("Sheet1")
        .Columns(2).ClearContents
        rowcount = 1
        Do While .Range("A" & rowcount) <> ""
            searchwords = .Range("A" & rowcount).Value
            ' Get keywords and validate by adding + for spaces between
            ' Broad Search
            '    searchwords = Replace(searchwords, " ", "+")
            ' Phrase Search
            searchwords = Replace(searchwords, " ", "+")
            If Left(searchwords, 1) <> """" Then searchwords = """" & searchwords
            If Right(searchwords, 1) <> """" Then searchwords = searchwords & """"
            ' Obtain the source code for the Google-searchterm webpage
            'https://www.google.com.au/#hl=en&output=search&q=my+custom+search&oq=my+custom+search
            search_url = "https://www.google.com/search?hl=en&output=search&q=" & URLEncode(searchwords) & "&oq=" & URLEncode(searchwords)
            Set search_http = CreateObject("MSXML2.XMLHTTP")
            'InputBox "URL:", "URL", search_url
            search_http.Open "GET", search_url, False
            search_http.send
            results_var = CStr(search_http.responsetext)
            
            Set search_http = Nothing
            ' Find the number of results and post to sheet
            strResultStart = "<div id=""resultStats"">"
            pos_1 = InStr(results_var, strResultStart)
            If pos_1 > 0 Then
                pos_1 = pos_1 + Len(strResultStart)
                pos_2 = InStr(pos_1, results_var, "<nobr>", vbTextCompare) - 1
                NumberOfResults = Mid(results_var, pos_1, pos_2 - pos_1 + 1)
                ' MsgBox NumberOfResults
                Range("B" & rowcount) = Replace(Replace(Replace(NumberOfResults, "About ", ""), " results", ""), " result", "")
            Else
                Range("B" & rowcount) = "0"
            End If
            rowcount = rowcount + 1
        Loop
    End With
End Sub

Function URLEncode(strURLString)
    ' TITLE: URLEncode
    ' DESCRIPTION: This function will modify a string into a URL friendly string
    '   by replacing URL invalid characters with the equivalent hex codes.
    ' INPUT:
    '   strURLString contains a string that is to be encoded into a URL friendly string
    ' OUTPUT:
    '   A string value that is the string encoded with the hex codes for the invalid characters
    strTemp = ""
    strChar = ""
    For intPos = 1 To Len(strURLString)
        intASCII = Asc(Mid(strURLString, intPos, 1))
        If intASCII = 32 Then
            strTemp = strTemp & "%20"
        ElseIf ((intASCII < 123) And (intASCII > 96)) Then
            strTemp = strTemp & Chr(intASCII)
        ElseIf ((intASCII < 91) And (intASCII > 64)) Then
            strTemp = strTemp & Chr(intASCII)
        ElseIf ((intASCII < 58) And (intASCII > 47)) Then
            strTemp = strTemp & Chr(intASCII)
        Else
            strChar = Trim(Hex(intASCII))
            If intASCII < 16 Then
                strTemp = strTemp & "%0" & strChar
            Else
                strTemp = strTemp & "%" & strChar
            End If
        End If
    Next
    URLEncode = strTemp
End Function

Select allOpen in new window

Awesome, thank you so much!