To automate google search and provide top 10 links

If you would like automate the Google search and would like to know what are all the top 10 websites for the particular search, Here is the macro that automate all your Google searches:

Macro Code:

'' Change this if you want rankings for a region-specific google website, like www.google.co.uk
'' Or, change it to a specific data center IP, like the Caffeine test server: 209.85.225.103
Const GOOGLE_WEBSERVER = "www.google.com"

'' Amount of default-sized result pages to scan
Const PagesToScan = 1

'' Builds the URL of a SERP for a term, starting at a certain result
Function BuildSERPURL(ByVal term As String, ByVal start As Long) As String
BuildSERPURL = "http://" & GOOGLE_WEBSERVER & "/search?start=" & start & "&q=" & term
End Function

'' Fetches a page from the internet
Function FetchPage(ByVal url As String) As String
Dim req As WinHttp.WinHttpRequest
Set req = New WinHttp.WinHttpRequest
req.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
req.Open "GET", url
req.Send
FetchPage = req.ResponseText
End Function

'' Separates and retrieves the hostname from a URL
Function GetHostname(ByVal url As String)
GetHostname = url
End Function

'' Finds an empty row for a new competitor site. Returns the row index
Function FindNextRow()
For Each cell In ActiveSheet.Columns(2).Cells
If Len(cell.Text) < 1 Then
FindNextRow = cell.row
Exit Function
End If
Next
FindNextRow = -1
End Function

'' Processes a single search term
Sub ProcessTerm(ByVal term As String, ByVal myurl As String)
Dim sheet As Worksheet
Dim url As String, contents As String
Dim row As Long, start As Long, page As Long
Dim foundMyUrl As Boolean

Set sheet = Application.ActiveSheet
start = 0
foundMyUrl = False
For page = 1 To PagesToScan
url = BuildSERPURL(term, start)
contents = FetchPage(url)

Dim pos As Long, posEnd As Long
pos = 1
pos2 = 1
Const sig = "

Const Sig2 = "')"">"

'' Find first link
pos = InStr(pos, contents, sig)
pos2 = InStr(pos, contents, Sig2)


While (pos > 0)

pos = pos + Len(sig)
pos2 = pos2 + Len(Sig2)


'' Find end of link
posEnd = InStr(pos, contents, """")
posEnd2 = InStr(pos2, contents, "

")
If posEnd < 1 Then
MsgBox "Failed to parse Google results page"
Exit Sub
End If

'' Extract the URL from the link
url = Mid(contents, pos, posEnd - pos)
a = Mid(contents, pos2, posEnd2 - pos2)

start = start + 1

'If InStr(url, myurl) > 0 Then
'' This my URL. Everything from here on is below me
'foundMyUrl = True
'Else
hostname = GetHostname(url)
row = -1

'' Locate this competitor URL in the existing list
On Error Resume Next
'row = Application.WorksheetFunction.Match(hostname, sheet.Columns(3), 0)
On Error GoTo 0

If row < 2 Then
'' This competitor does not already exist, so add a new row for it
row = FindNextRow
sheet.Cells(row, 2).Value = hostname
sheet.Cells(row, 3).Value = a
'sheet.Cells(row, 5).Value = 0
'' Row exists
End If

'' Count this appearance either below or above me
'If foundMyUrl Then
' sheet.Cells(row, 5).Value = sheet.Cells(row, 5).Value + 1
' Else
'sheet.Cells(row, 4).Value = sheet.Cells(row, 4).Value + 1
'End If
' End If

'' Find next link
pos = InStr(pos, contents, sig)
pos2 = InStr(pos2, contents, Sig2)
Wend
sheet.Cells(row, 2).ClearContents
sheet.Cells(row, 3).ClearContents
Next

Columns("C:C").Select
Selection.Replace What:="", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Range("A1").Select

End Sub

'' Main routine
Sub CompetitorResearch()
Dim sheet As Worksheet
Set sheet = Application.ActiveSheet

'' Retrieve my url
Dim myurl As String
myurl = sheet.Cells(2, 1).Text

'' Work through the list of search terms and process each one
row = 2
While (sheet.Cells(row, 1).Text <> "")
Dim term As String
term = sheet.Cells(row, 1).Text
ProcessTerm term, myurl
row = row + 1
Wend

'' Order the result list by "Above me" and then by "Below me", so stronger competitors appear first

'sheet.Range("C:E").Sort sheet.Columns(4), xlDescending, _
sheet.Columns(5), , xlDescending, _
, , xlYes

End Sub