Lookup First URL From Google Search Result Using VBA

**joparo** · 05-14-2013, 11:59 PM

**Excel Fox** · 05-15-2013, 11:36 AM

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!

**Excel Fox** · 05-15-2013, 12:28 PM

**joparo** · 05-15-2013, 12:43 PM

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

**Excel Fox** · 05-15-2013, 02:12 PM

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

**Excel Fox** · 05-15-2013, 04:20 PM

A much better alternative to my URLENCODED function is given at FreeVBCode code snippet: URLEncode for Large Strings

**joparo** · 05-15-2013, 10:09 PM

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.

**Excel Fox** · 05-15-2013, 10:32 PM

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.

**LalitPandey87** · 05-16-2013, 02:07 PM

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

**SirJB7** · 05-18-2013, 04:08 AM

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!