Lookup First URL From Google Search Result Using VBA

[joparo]

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/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg.9gxsUMU53al9k5c8W6QG E8)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4ISxLD1 7d)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h4LdsDET im)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_ (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=Ugz2PzvZTJyxHz70eVF4AaABAg.9gxDYq2iiZ89h32czjty R_)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxzpgHWTLGj0C3q3gx4AaABAg (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=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=Ugy7vmiHsQ0oUt2QCPZ4AaABAg.9gvoy4OW6lU9gxwxC5-rL9)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0 (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgzuX3uYmqJRtsZIbqF4AaABAg.9gth61YhXKB9gxxCMdRL A0)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgxcPC64RQGmXwO5rft4AaABAg.9gtQLXaeg0e9gxxNuc5C CM)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj (https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwCY8vOs1DFHgYSJwF4AaABAg.9godrFcyWYw9gxy1odpi Rj)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgyL5nh_j8w70-YBoUt4AaABAg.9goMcRjwjtc9gxyslvuZKx (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=UgwwWRgmRZNqJKptHR14AaABAg.9go-DbayTZa9gxzPbefHXf)
https://www.youtube.com/watch?v=xLCWtC6UYrM&lc=UgwF3wECwc8tVoRmz6B4AaABAg.9go-5xLQM8P9gxzmB7nkVQ (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/watch?v=xLCWtC6UYrM&lc=UgyRDmGTHnMdT7dl_qx4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[Excel Fox]

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



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.18 3.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]

By the way, this is where I picked up the HTML URL Encoding Reference (http://www.w3schools.com/tags/ref_urlencode.asp)

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (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=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=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=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=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=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=312727#p312727)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724 (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?f=44&t=40374&p=312535#p312535)
https://www.eileenslounge.com/viewtopic.php?p=312533#p312533 (https://www.eileenslounge.com/viewtopic.php?p=312533#p312533)
https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499 (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.9xhyRrsUUOM9xpn-GDkL3o)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg (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)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg.9zYoeePv8sZ9zYqog9KZ 5B (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg.9zYoeePv8sZ9zYqog9KZ 5B)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[joparo]

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]

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.18 3.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]

A much better alternative to my URLENCODED function is given at FreeVBCode code snippet: URLEncode for Large Strings (http://www.freevbcode.com/ShowCode.asp?ID=5137)

[joparo]

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]

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]

You may also try this:
My data is staring from A2 and A1 contains heading.



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:

[SirJB7]

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 (http://chandoo.org/forums/topic/can-this-be-automated-any-help?replies=11#post-103200)

Regards!

[Excel Fox]

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 (http://www.dailyfinance.com/2011/07/11/american-express-black-the-worlds-most-exclusive-charge-card/) 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 (http://www.excelfox.com/forum/f22), 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

[SirJB7]

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.

[Excel Fox]

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

[SirJB7]

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

[joparo]

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

[joparo]

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?

[Excel Fox]

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.

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

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.

[joparo]

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)

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

[bakerman]

Dim objMXHTML As Object

[joparo]

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

[joparo]

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?

[superspike711]

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:

[superspike711]

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


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

[Excel Fox]

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

[Mohamed Abdel Latef]

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

[charly420]

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

[stefanoste78]

Good evening.
Could you update this code?
Thank you