Page 1 of 4 123 ... LastLast
Results 1 to 10 of 31

Thread: Lookup First URL From Google Search Result Using VBA

  1. #1
    Junior Member
    Join Date
    May 2013
    Posts
    11
    Rep Power
    0

    Lookup First URL From Google Search Result Using VBA

    hi, is this possible to automate, every day i get like 2000 company names of NGOs across usa, in excel, i have to copy each company name and put it in google and get the URL...is it possible to automate it through excel programming or macros.



    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg. 9gxsUMU53al9k5c8W6QGE8
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg. 9gxDYq2iiZ89h4ISxLD17d
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg. 9gxDYq2iiZ89h4LdsDETim
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg. 9gxDYq2iiZ89h32czjtyR_
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugw_smEwvNffCPr_nrB4AaABAg. 9gvyL53lI1l9gxwd_9-V6z
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugy7vmiHsQ0oUt2QCPZ4AaABAg. 9gvoy4OW6lU9gxwxC5-rL9
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg. 9gth61YhXKB9gxxCMdRLA0
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg. 9gtQLXaeg0e9gxxNuc5CCM
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg. 9godrFcyWYw9gxy1odpiRj
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwwWRgmRZNqJKptHR14AaABAg. 9go-DbayTZa9gxzPbefHXf
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg. 9go-5xLQM8P9gxzmB7nkVQ
    https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 07-11-2023 at 12:09 PM.

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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!
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Last edited by DocAElstein; 03-01-2024 at 02:54 PM.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  4. #4
    Junior Member
    Join Date
    May 2013
    Posts
    11
    Rep Power
    0
    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

  5. #5
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  6. #6
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    A much better alternative to my URLENCODED function is given at FreeVBCode code snippet: URLEncode for Large Strings
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  7. #7
    Junior Member
    Join Date
    May 2013
    Posts
    11
    Rep Power
    0
    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.

  8. #8
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  9. #9
    Senior Member LalitPandey87's Avatar
    Join Date
    Sep 2011
    Posts
    222
    Rep Power
    14
    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

  10. #10
    Junior Member SirJB7's Avatar
    Join Date
    May 2013
    Posts
    3
    Rep Power
    0

    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!
    Last edited by Excel Fox; 05-18-2013 at 09:36 AM. Reason: Added URL Tag For Better Readability

Similar Threads

  1. Replies: 4
    Last Post: 04-24-2013, 10:04 AM
  2. Find the highest then lookup result
    By Stalker in forum Excel Help
    Replies: 4
    Last Post: 04-02-2013, 02:04 PM
  3. Import html source of url list in each cell
    By Sergio Alfaro Lloret in forum Excel Help
    Replies: 8
    Last Post: 07-31-2012, 03:03 AM
  4. VBA Function to Search in Array
    By Admin in forum Excel and VBA Tips and Tricks
    Replies: 0
    Last Post: 04-10-2012, 11:34 AM
  5. VBA - Excel: Disable Internet / Google
    By technicalupload in forum Excel Help
    Replies: 3
    Last Post: 10-06-2011, 09:18 AM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •