Lookup First URL From Google Search Result Using VBA

[joparo]

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

[Excel Fox]

Try this

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
            Set objMXHTML = CreateObject("MSXML2.XMLHTTP")
            For Each rngCell In rngRange
                With objMXHTML
                    .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

[joparo]

when I run this code I get an error. compile error: Variable not found.