検索結果のURLの取得

質問

こんにちは、ExcelVBAの初心者です。
上司から検索サイトでの検索結果に出てくる上位URLをコピー＆ペーストするように指示を受けたのですが、作業が大変で全然進まず困っています。
もしからた、ExcelVBAで解決できるのではと、ご相談させて頂きました。

具体的には以下のような作業を手作業でやっています。
これを自動化することは可能でしょうか？

１．エクセルに検索するキーワードがセル（Ａ列）ごとにおさめられています。
（セルには２つのキーワードが入っていてand条件となります）
２．それをコピーしてyahooかgoogleで検索をします。
３．検索結果の上位３つまでのURLをコピーして、キーワードの右側のセルにペーストしています。（スポンサードサーチなど広告系は含みません）

【イメージです】
　　　　　　　　Ａ　　　　　　　　　　　　Ｂ　　　　　　　　　　　　　　Ｃ　　
　　――――――――――――――――――――――――――
１｜カメラ　SONY　　　　　｜＿＿＿＿＿＿＿＿｜＿＿＿＿＿＿
２｜電子レンジ　シャープ｜＿＿＿＿＿＿＿＿｜＿＿＿＿＿＿
３｜冷蔵庫　日立　　　　　｜＿＿＿＿＿＿＿＿｜＿＿＿＿＿＿

　　　　　　　　　　　　↓

　　　　　　　　Ａ　　　　　　　　　　　　Ｂ　　　　　　　　　　　　　　Ｃ　　
　　――――――――――――――――――――――――――
１｜カメラ　SONY　　　　　｜www.sony.jp/dslr｜www.sony.co.jp
２｜電子レンジ　シャープ｜healsio.jp　　　　　｜www.sharp.co.jp/sup
３｜冷蔵庫　日立　　　　　｜＿＿＿＿＿＿＿＿｜＿＿＿＿＿＿

素人で実現可能なのかも分かりませんが、もし分かる方がいらっしゃいましたら何卒お知恵をお貸しください。
どうかよろしくお願いいたします。

回答No.4

xls88 · ベストアンサー

利用規約に抵触しているようです。

接続に関する問題: ネットワークで表示される「申し訳ありません」ページ
http://www.google.co.jp/support/websearch/bin/answer.py?hl=jp&answer=86640
サービス利用規約
http://oshiete1.goo.ne.jp/kotaeru_reply.php3?q=5689504

お礼

ご回答ありがとうございます。
やっぱりなかなか上手くいかないものですね。

VBAでは無理ということが分かっただけでも良かったです。
地道に手作業でやっていきます。

ご親切にいろいろありがとうございました（^^

回答No.3

xls88

Dim i As Integer

myUrl = "http://www.google.co.jp/"
For Each myWindow In CreateObject("Shell.Application").Windows
With myWindow
'//Google
If .LocationURL = myUrl Then
For Each c In Sheets("Sheet1").Range("A1:A10")
i = 0

上記の部分を下記に変えてください。
検索キーワードが、連続で入力されている範囲を取得します。
数千行あると、どれほど時間がかかるか解りません。
検索キーワードの数を減じた、ダミーシートでテストしてください。

Dim i As Integer
Dim drng As Range

With Sheets("Sheet1")
Set drng = .Range("A1", .Range("A1").End(xlDown))
End With

myUrl = "http://www.google.co.jp/"
For Each myWindow In CreateObject("Shell.Application").Windows
With myWindow
'//Google
If .LocationURL = myUrl Then
For Each c In drng
i = 0

補足

回答ありがとうございます。
10行以上目移行も動いてくれるようになりました。
ただ、しばらく検索（50～100行）くらい進むと下記の英文が表示され、検索が出来なくなってしまいます。（自動化に対してのエラーでしょうか？）
これは、もう仕方ないのでしょうか？
それともYahooなどですと起こらないのでしょうか？

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
We're sorry...
... but your computer or network may be sending automated queries. To protect our users, we can't process your request right now.
See Google Help for more information.
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

回答No.2

xls88

とりあえず、検索結果のURLを3つ抽出します。
適当に条件を付けています。
厳密に上位の3つというわけではありません。

Sheet1のA1:A10に検索キーワードと仮定
検索キーワードが数千行もあると、どれほど時間がかかるか解りません。

Sub test1()
Dim myWindow As Object
Dim myUrl As String
Dim tmp As Object
Dim myLink As Object
Dim c As Range
Dim i As Integer

myUrl = "http://www.google.co.jp/"
For Each myWindow In CreateObject("Shell.Application").Windows
With myWindow
'//Google
If .LocationURL = myUrl Then
For Each c In Sheets("Sheet1").Range("A1:A10")
i = 0
'//Google検索
.Document.all.Tags("input").Item("q").Value = c.Value
.Document.all.Tags("input").Item("btnG").Click
Call webReadyState(myWindow)

'//検索結果抽出
For Each myLink In .Document.Links
If InStr(myLink, "google") = 0 Then
If InStr(myLink, "%") = 0 Then
If Right(myLink, 1) = "/" Then
i = i + 1
c.Offset(, i).Value = myLink
End If
End If
End If
If i = 3 Then Exit For
Next myLink
.GoBack
Call webReadyState(myWindow)
Next
Exit For
End If
End With
Next myWindow
Set tmp = Nothing
End Sub

Sub webReadyState(myWindow)
With myWindow
Do While .Busy = True
DoEvents
Loop
Do While .ReadyState <> 4
DoEvents
Loop
End With
End Sub

補足

回答ありがとうございます。
希望通りの動きでした！(^^

ただ、どうしても10行目で止まってしまいます。
10行目以降も取得を自動で進めることが出来ないでしょうか？

回答No.1

xls88

とりあえず下記のようにしてみました。
IEでGoogleを開いている状態で実行してください。

Dim myWindow As Object
Dim myUrl As String
Dim tmp As Object
Dim i As Integer

myUrl = "http://www.google.co.jp/"
For Each myWindow In CreateObject("Shell.Application").Windows
With myWindow
'//Google
If .locationurl = myUrl Then
'//Google検索
.Document.all.Tags("input").Item("q").Value = Range("A1").Value
.Document.all.Tags("input").Item("btnG").Click

Do While .Busy = True
DoEvents
Loop
Do While .ReadyState <> 4
DoEvents
Loop

'//検索結果抽出
If .locationurl Like "http://www.google.co.jp/search*" Then
Set tmp = .Document.getElementsByTagName("a")
For i = 0 To tmp.Length - 1
If tmp(i).innertext Like "*ソニー" Then
MsgBox Range("A1").Value & vbLf & tmp(i).innertext & vbLf & tmp(i).href
End If
Next i
End If
.GoBack
Exit For
End If
End With
Next myWindow

Set tmp = Nothing

補足

回答ありがとうございます(^^
イメージしているものにすごく近いです。
ボックスに入ってくるURLがB,C,D列に自動的に入っていくように出来ますでしょうか？
あと、Excelに入ったの検索キーワードが数千行あるので、そのキーワードがgoogleの検索ボックスに自動的に入力されURLを取得し終わったら、また次の行のキーワードを、、、　と一連の作業がすべて自動的で出来るでしょうか？
難しいことをいってすみません。