-
Lookup First URL From Google Search Result Using VBA
-
1 Attachment(s)
Here's how you do it. I've attached a working file also (Excel 2007+). Post back if you are using Excel 2003-.
For those interested in the code, and don't want to download the file itself, this is what it looks like
Code:
Dim var As Variant
Sub SearchGoogle()
Dim IE As InternetExplorer
Dim objDoc As HTMLDocument
Dim objTextBox As HTMLInputElement
Dim objSubmitButton As HTMLButtonElement
Dim rng As Range
Dim obj As Object
Dim lngCol As Long
Worksheets("Sheet1").Range("B2:B" & Rows.Count).ClearContents
Set rng = Worksheets("URLEncoding").Cells(1).CurrentRegion
ReDim var(1 To rng.Rows.Count, 1 To 2)
For Each rng In rng.Columns(1).Cells
var(rng.Row, 1) = rng.Text
var(rng.Row, 2) = rng.Offset(, 1).Text
Next rng
Const STRURL = "http://www.google.com/#output=search&sclient=psy-ab&q=|+|&rlz=1W1LENP_enIN497&oq=|+|&gs_l=hp.12..0l4.22785.22785.0.52909.1.1.0.0.0.0.183.183.0j1.1.0...0.0...1c..12.psy-ab.Zd3_T9FwkMg&pbx=1&bav=on.2,or.r_qf.&bvm=bv.46471029,d.bmk&fp=dd21897ce84632f&biw=1704&bih=928"
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
For Each rng In Worksheets("Sheet1").Range("A2:A20000")
If Not IsEmpty(rng) Then
IE.Navigate Replace(STRURL, "|+|", URLENCODED(rng.Value))
While IE.Busy: Wend 'wait until IE is done loading page.
While IE.readyState <> READYSTATE_COMPLETE: Wend
Application.Wait Now() + TimeValue("00:00:02")
Set objDoc = IE.document
For Each obj In objDoc.getElementsByTagName("A")
If MIMEINCLUDE(obj.mimeType) Then lngCol = lngCol + 1
If lngCol = 6 Then
rng.Offset(, 1).Value = obj.href
lngCol = 0
Exit For
End If
Next obj
Else
Exit For
End If
Next rng
Set objDoc = Nothing
Set objTextBox = Nothing
Set rng = Nothing
IE.Quit
End Sub
Private Function URLENCODED(str) As String
Dim lng As Long
Dim lngRow As Long
For lngRow = LBound(var) To UBound(var)
str = Replace(str, var(lngRow, 1), var(lngRow, 2))
Next lngRow
URLENCODED = str
End Function
Private Function MIMEINCLUDE(str As String)
Const strDOM As String = "COM,ORG,IN,AU,US"
Dim lng As Long
For lng = LBound(Split(strDOM, ",")) To UBound(Split(strDOM, ","))
If str = Split(strDOM, ",")(lng) & "/ File" Then
MIMEINCLUDE = True: Exit For
End If
Next lng
End Function
I don't claim it to be 100% fool proof. I may be missing or overlooking something that should be very obvious, but it's working for me!
-
-
thanks for the quick reply and your help, after i hit Run, this is what comes up in URL. Any help?
http://www.blogger.com/?tab=wj
http://www.blogger.com/?tab=wj
http://www.blogger.com/?tab=wj
-
1 Attachment(s)
You could have corrected it by increasing the Wait time, but I thought let's go one step better.
Try this...
Code:
Option Explicit
Dim var As Variant
Sub SearchGoogle()
Dim IE As InternetExplorer
Dim objDoc As HTMLDocument
Dim objTextBox As HTMLInputElement
Dim objSubmitButton As HTMLButtonElement
Dim rng As Range
Dim obj As Object
Dim lngCol As Long
Worksheets("Sheet1").Range("B2:B" & Rows.Count).ClearContents
Set rng = Worksheets("URLEncoding").Cells(1).CurrentRegion
ReDim var(1 To rng.Rows.Count, 1 To 2)
For Each rng In rng.Columns(1).Cells
var(rng.Row, 1) = rng.Text
var(rng.Row, 2) = rng.Offset(, 1).Text
Next rng
Const strURL = "http://www.google.com/#output=search&sclient=psy-ab&q=|+|&rlz=1W1LENP_enIN497&oq=|+|&gs_l=hp.12..0l4.22785.22785.0.52909.1.1.0.0.0.0.183.183.0j1.1.0...0.0...1c..12.psy-ab.Zd3_T9FwkMg&pbx=1&bav=on.2,or.r_qf.&bvm=bv.46471029,d.bmk&fp=dd21897ce84632f&biw=1704&bih=928"
Set IE = New InternetExplorer 'CreateObject("InternetExplorer.Application")
IE.Visible = True
For Each rng In Worksheets("Sheet1").Range("A2:A20000")
INavigate IE, "http://www.google.com/"
If Not IsEmpty(rng) Then
INavigate IE, Replace(strURL, "|+|", URLENCODED(rng.Value))
While obj Is Nothing
Set obj = Nothing
On Error Resume Next
Set obj = IE.document.getElementById("ires")
Err.Clear: On Error GoTo 0: On Error GoTo -1
Wend
While obj.readyState <> "complete": Wend
Set obj = Nothing
Set objDoc = IE.document
For Each obj In objDoc.getElementsByTagName("A")
If MIMEINCLUDE(obj.mimeType) Then lngCol = lngCol + 1
If lngCol = 6 Then
rng.Offset(, 1).Value = obj.href
lngCol = 0
Exit For
End If
Next obj
Else
Exit For
End If
Set obj = Nothing
Next rng
Set objDoc = Nothing
Set objTextBox = Nothing
Set rng = Nothing
IE.Quit
End Sub
Private Function URLENCODED(str) As String
Dim lng As Long
Dim lngRow As Long
For lngRow = LBound(var) To UBound(var)
str = Replace(str, var(lngRow, 1), var(lngRow, 2))
Next lngRow
URLENCODED = str
End Function
Private Function MIMEINCLUDE(str As String)
Const strDOM As String = "COM,ORG,IN,AU,US"
Dim lng As Long
For lng = LBound(Split(strDOM, ",")) To UBound(Split(strDOM, ","))
If str = Split(strDOM, ",")(lng) & "/ File" Then
MIMEINCLUDE = True: Exit For
End If
Next lng
End Function
Private Sub INavigate(IE As InternetExplorer, strURL)
IE.Navigate strURL
While IE.Busy: Wend 'wait until IE is done loading page.
While IE.readyState <> READYSTATE_COMPLETE: Wend
End Sub
-
A much better alternative to my URLENCODED function is given at FreeVBCode code snippet: URLEncode for Large Strings
-
hey fox...thank you for your efforts...i tried all your ways...the latest one.look up file. tried with the code as well. when i hit run..nothin happens, later on i get a pop up...waiting for olean application..then i click okay...it hangs.
-
Working absolutely fine for me. For this to work, you must not be logged in to Google account, and your default domain should be a .COM instead of anything else.... I haven't figured a work around for this.
-
You may also try this:
My data is staring from A2 and A1 contains heading.
Code:
Option Explicit
Sub lm_GetGooleFirstSearchAddres()
Dim strHtml As String
Dim lngLoop As Long
Dim rngRange As Range
Dim rngCell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rngCell = .Range("A1").CurrentRegion.Resize(, 1)
Set rngRange = Nothing
On Error Resume Next
Set rngRange = Intersect(rngCell, rngCell.Offset(1))
On Error GoTo -1: On Error GoTo 0: Err.Clear
If Not rngRange Is Nothing Then
For Each rngCell In rngRange
With CreateObject("MSXML2.XMLHTTP")
.Open "get", URLEncode(rngCell.Value), False
.send
strHtml = .responseText
strHtml = Mid(strHtml, InStr(1, strHtml, "<div id=""ires"">"))
strHtml = Mid(strHtml, 1, InStr(1, strHtml, "<div class=""s"">"))
strHtml = Mid(strHtml, InStr(1, strHtml, "<a href="))
strHtml = Mid(strHtml, InStr(1, strHtml, "<a href="), InStr(1, strHtml, """ onmousedown="""))
strHtml = Mid(strHtml, InStr(1, strHtml, """"), Len(strHtml) - 1)
rngCell.Offset(, 1).Value = Mid(Trim(strHtml), 2, Len(Trim(strHtml)) - 2)
End With
Next rngCell
MsgBox "Search completed.", vbInformation, "Google Search..."
Else
MsgBox "No data found to search.", vbCritical, "Google Search..."
End If
End With
strHtml = vbNullString
lngLoop = Empty
Set rngRange = Nothing
Set rngCell = Nothing
End Sub
Function URLEncode(EncodeStr As String) As String
Dim i As Integer
Dim erg As String
Const strGogSrchUrl As String = " http://www.google.co.in/search?output=search&sclient=psy-ab&q=|||&btnK="
Const strConcatDelima As String = "|||"
erg = EncodeStr
' *** First replace '%' chr
erg = Replace(erg, "%", Chr(1))
' *** then '+' chr
erg = Replace(erg, "+", Chr(2))
For i = 0 To 255
Select Case i
' *** Allowed 'regular' characters
Case 37, 43, 48 To 57, 65 To 90, 97 To 122
Case 1 ' *** Replace original %
erg = Replace(erg, Chr(i), "%25")
Case 2 ' *** Replace original +
erg = Replace(erg, Chr(i), "%2B")
Case 32
erg = Replace(erg, Chr(i), "+")
Case 3 To 15
erg = Replace(erg, Chr(i), "%0" & Hex(i))
Case Else
erg = Replace(erg, Chr(i), "%" & Hex(i))
End Select
Next
URLEncode = Replace(strGogSrchUrl, strConcatDelima, erg)
'URLEncode = strGogSrchUrl & erg
i = Empty
erg = vbNullString
End Function
:cheers:
-
Another approach
Hi, joparo!
This is a link to an alternative suggested solution posted at Chandoo's website where you started this topic/thread too :
Search Result Using Query Table
Regards!
