Lookup First URL From Google Search Result Using VBA

[Excel Fox]

You could have corrected it by increasing the Wait time, but I thought let's go one step better.

Try this...

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