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

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!

By the way, this is where I picked up the HTML URL Encoding Reference

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.eileenslounge.com/viewtopic.php?f=44&t=40455&p=313035#p313035
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312889#p312889
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312886#p312886
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312752#p312752
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312734#p312734
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312727#p312727
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724
https://www.eileenslounge.com/viewtopic.php?f=44&t=40374&p=312535#p312535
https://www.eileenslounge.com/viewtopic.php?p=312533#p312533
https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9xpn-GDkL3o
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg. 9zYoeePv8sZ9zYqog9KZ5B
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9zYlZPKdOpm
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

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

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:

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!

SirJB7,

May I request you to remove the second last post from the thread you've posted above. We don't offer a Black Amex or any money for helping the MS-Office online community. You must have noted that we give help not just in Excel, but also most of the other applications in the MS-Office Suite.

We have no disregard for the site you're associated with. We'd expect the same in return. The way I look at it, OP has received three different solutions to the problem, and as solution providers, it should be considered as a win for yourself and us here.

PS: OP posted the query here at least 4 hours before posting it at the thread you mentioned above. And since most of us are at +5.30 GMT, we were only able to provide a solution in the morning.

The reasons why we expect someone to register is just for the sake of a figure, that may give us a sense of pride to have X registered members. If you look at Rick Rothstein's Corner, you'd notice that one doesn't need to register to read the thread. We have our own ways of doing things, and I am sure you have your own. You are free to give a thumbs down to what you deem should be 'thumbs-downed', but as a fellow Excellian or as a fellow online help volunteer, we'd expect you to maintain a sense of respect for other communities that are only trying to help others.

Kris (Admin), and I, we are two different people. Both of us are part of many other forums, and have been helping the online community for many years, having well over 15000 posts between us. Most of the solution providers here are our friends and volunteers who we've come across at different forums and work places. Admonishing someone not to post a cross-post link doesn't come from 'greatness' or even from 'keeping forum sanity in check', but it comes from a sense of contempt and highhandedness.

On a more regular note, we (and I personally) welcome you to the ExcelFox community. Glad to have you here. Feel free to post MS-Office related suggestions / posts whenever you feel like. Even with your vast experience and knowledge, I am sure there may be fractions of a percentage that we can add to your knowledge.

Happy helping.

Regards,
EF

Hi, Excel Fox!

I sincerely apologize for the misunderstanding. As soon as I received the email notice of this message I proceeded to edit the related post trying to clarify and added a link to this thread.

Absolutely nothing farther from my intentions than starting at a new forum in this way, so I thank you very much for your welcome words. I don't agree with the knowledge flow that may arise. If you could have read my Interest section of my profile at Chandoo's forums there it says: "Technical? Improve and apply". Despite of this I strongly believe in a phrase from Albert Einstein, please forgive if my non-native English play a trick on me: "We are all very ignorant, what happens is that not all ignore the same things".

Regarding your request of removing the related post I hope that the explanations given were suitable for you. Towards the future I wish that both sides of the scale get balanced, either suggesting solutions or incorporating knowledge.

Lastly I must say that I completely disagree about your words about crossposting and following actions, but I'll play with the house rules, if I play, so don't expect reading me here alike.

Best regards.

SirJB7,

We respect your thoughts. No offense taken. And the clarification you've given over there has been taken in the right earnest.

Regarding cross posting, we here also are in lines with all other forums, including Chandoo and we ask people to inform the forum if the same thread is started elsewhere. My only specific comment above was basis this specific case only. So yes, we agree and feel the same way as you and all other forum volunteers feel about cross posting.

Would appreciate you helping the online community here as well, as you're doing for other communities.

Regards from this forum again.

Thanks,
EF

Hi, joparo!
There's a new enhanced version at the same previous link of my first comment.
Regards!

Permission to use object denied? any help to fix this error?

hi all, the code stops working as i get a pop up "permission to use the object denied"
it runs for a while like copies few links and error message 419

things i tried:

removed all the add-ins

logged in as administrator

stopped using anti virus

found xlstart folder empty

error still there, any help?

You haven't mentioned which version of the code you are facing problem with. If you facing problem with all the codes, then there must be some administrative problems (can't tell for sure). If it's a specific code from this thread, or from the one from the other link, mention which one.

HTML 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

---

Tested the code, it's working absolutely fine here. Can you tell me exactly what are you searching for? Maybe it has something to do with the search word, or its URL.

hi, in excel sheet i got list of ngo companies, when i run this code, it pulls the domain names, after like 70or 80 companies...i get a pop up that " VB Permission to use object denied (Error 419)

Try this

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
            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

---

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

Code:

---

Dim objMXHTML As Object

---

still get the error 419 permission to use the object denied ?

Hi Lalit i have been using your code, it works fine after few minutes i get this crazy error "permission to use the object denied" error 419. i tried few things altering the code, didn't work, so the best person to ask is the creator, any help?

Excel Fox,
The macro you created no longer works. I think the html page formatting has changed since you wrote it.
I am definitely no expert but I rewrote It anyway. It's messy but seems much faster and did not crap out during 4200 entry search.
Regards
Spike

File attached:

Sorry about caps lock . . .
Here is Code from file:

Code:

---

Option Explicit
Dim var As Variant

Sub SearchBing()
   
    Dim rng As Range
    Dim lngCol As Long
    Dim oXML As New MSXML2.XMLHTTP
    Dim uTxt As Variant
    Dim xURL As String
   
    Dim srchString As Variant
    Dim StrStart As Variant
    Dim StrEnd As Variant
    Dim StrOutput As Variant
    Dim x As Variant
    Dim OutputRowNumber As Variant
   
    ' Clear Destination Column for URL Lookup
    Worksheets("Sheet1").Range("B2:B" & Rows.Count).ClearContents
   
     
    ' Set base search using bing instead of google because google's pages are a mess
    Const strURL = "http://www.bing.com/search?q=|+|"
    ' Move through source cells
    For Each rng In Worksheets("Sheet1").Range("A2:A5000")
        ' Make sure range is not empty before we start
        If Not IsEmpty(rng) Then
            ' encode url for direct submission
            xURL = Replace(strURL, "|+|", URLEncode(rng.Value))
            'Debug.Print xURL
            ' set object parameters
            oXML.Open "GET", xURL, False
            oXML.setRequestHeader "Content-Type", "text/xml"
           
            ' Delay request by wait to allow catchup and to not freakout
            ' search firewalls
            x = x + 1
            If x = 6 Then
            x = 0
            'Slow it down a bit
            DoEvents
            End If
            'Debug.Print "x=" & x
                     
            ' if you don't have this program will crap out if it encounters weird
            ' formatted page
            On Error Resume Next
           
            'Send request returns page of searchable xml text to oXML object
            oXML.send
            'FIRST SEARCH PRIORITY
            ' srchstring finds unique string in the ballpark of what you want
            ' add more searchs if you want other information or if you want to
            ' get check more accurate info from page if it is available
            ' this section finds "website" button that sometimes appears on the right
            ' of bing search results
            srchString = "role=""button"" href=""http"
            ' extract small chunk of text so you can search again without dupes
            StrStart = InStr(1, oXML.responseText, srchString) + 20
            StrEnd = InStr(StrStart, oXML.responseText, 60)
            StrOutput = Mid(oXML.responseText, StrStart, StrEnd - StrStart - 3) & Chr(10)
           
            ' in the smaller string you extracted above drill down on the actual string
            ' you want - this one finds the first instance of http in the smaller string
            StrStart = InStr(1, StrOutput, "http")
            ' this one finds the end of the url by starting 9 after http and looks for "
            StrEnd = InStr(StrStart + 9, StrOutput, """")
            ' use start and end to isolate the web address
            StrOutput = Mid(StrOutput, StrStart, StrEnd - StrStart)
           
           
           
            'SECOND SEARCH PRIORITY
            ' using if-then If the first search does not find a website button it
            ' returns first item from search results. Note: First result is not always
            ' what you want
            If InStr(1, StrOutput, "www.w3.org") Then
                    srchString = "Search Results"
                    StrStart = InStr(1, oXML.responseText, srchString) + 47
                    StrEnd = InStr(StrStart, oXML.responseText, 60)
                    StrOutput = Mid(oXML.responseText, StrStart, StrEnd - StrStart - 3) & Chr(10)
           
           
                    StrStart = InStr(1, StrOutput, "http")
                    StrEnd = InStr(StrStart + 9, StrOutput, """")
                    StrOutput = Mid(StrOutput, StrStart, StrEnd - StrStart)
                   
            End If
           
            'Remove results that is too long (likely some sort of error)
            If Len(StrOutput) > 50 Then StrOutput = "NOT FOUND"
           
            'Cleanup Some of the Bad Addresses
            If InStr(1, StrOutput, "bloomberg.com") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "dandb.com") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "bing.com") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "wikipedia.org") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "doubleclick.net") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "brightscope.com") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "usnews.com") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "linkedin.com") Then StrOutput = "NOT FOUND"
            If InStr(1, StrOutput, "usnews.com") Then StrOutput = "NOT FOUND"
           
           
           
            'add row numbers for debugging
            'OutputRowNumber = OutputRowNumber + 1
            'Debug.Print OutputRowNumber & ": " & StrOutput
            'Debug.Print oXML.responseText
           
            rng.Offset(, 1).Value = StrOutput
           
        Else
            Exit For
        End If
    Next rng
    'set debugging row back to zero
    'OutputRowNumber = 0
    Set rng = Nothing
   

End Sub


Function URLEncode(EncodeStr As String) As String
    Dim i As Integer
    Dim erg 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 = erg
   
End Function

---

Thank you Spike for sharing the modified version. Much appreciated.

please my friend , i want VBa like this Vba above to extract email for domain but i want to extract emails of per domain from google and bing and yahoo to extract all emails of per domain in another page excel

Hello Excel Fox; Spike;

Thanks for the thread and the updates.

As regards to the last file submitted by Spike, the results extracted are only "http://www.w3.org/1999/xhtml".
I'm not sure I understand why there is a second search priority like yours .. Could you give me more info ?

Moreover, would this code apply to a google search ?

Thanks for your return

Good evening.
Could you update this code?
Thank you