グーグルに登録されているページをチェックしたい？

エクセルのＡ列にはURLが600ぐらいあるとします。
ある仕事をたのまれたのですが、
各ページがgoogleに登録されているかをチェックしています。
そこで効率のよいやり方（マクロ）があったら教えていただけないでしょうか？
Ｂ列には登録されている場合は「○」をつけ、登録されていない場合は「×」と記入しています。
IEを開いてgoogoleのページでコピペで調べているのですが、しんどいです。
どなたかお助けください。
よろしくお願いします。

No.1 回答者： g_liar 回答日時： 2010/12/21 15:23

やるとしたら・・・マクロというかExcel VBAを使って以下のようなプログラムを組む必要があります。

(1)VBA内部でInterlnet Explorerオブジェクトを生成。
(2)Ａ列のURLを取得し、googleの検索URLを作ってInterlnet Explorerオブジェクトに渡す。
(3)googleからの応答（＝Interlnet Explorerオブジェクトの処理終了）を待つ。
(4)googleから返されたHTMLをInterlnet Explorerオブジェクトから取得し、解析する。
(5)解析の結果、googleに登録済みならＢ列に「○」を挿入。
(6)シートに未解析分がなければ終了。あれば(2)へ。

たぶん4～50行程度のプログラムになるかな？
上に書いたことですぐにプログラムが思い浮かぶようなら、プログラムを作った方が早く作業が終わるでしょう。

どうすればよいかチンプンカンプンなら600個を手作業で確認した方が早く終わります。
同様の作業を将来的にも行うのでしたら、今のうちに勉強してプログラムを作っておいても良いかもしれません。

この回答へのお礼

回答ありがとうございます。

将来的にまだこの作業はあるみたいなので、プログラムを作りたいのですが、
ちょっとというか、全然手に負えません。

すいませんが、サンプル的なものでいいので教えてただけないでしょうか？

お手数ですがよろしくお願いします。

お礼日時：2010/12/21 16:04

No.2 回答者： merlionXX 回答日時： 2010/12/21 16:25

あまりインターネットサイトに詳しくないので「グーグルに登録されているページ」という意味がよくわかりません。

とんちんかんなことを言ってたらごめんなさい。
もしエクセルのA列に記載されているURLを自動で開いてくれるマクロが必要ということなら以下をお試しください。

１．URLをA列に記載したシートのシートタブをクリックして、コードの表示を選択
２．現れたシートモジュールに以下をコピペ
３．ALT+F11キーでシートに戻る

これでA列のセルをクリックしたら、記入されたURLのサイトが開きます。
下向矢印↓キーで順順に見ていけます。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Dim tmp As String
　　If Target.Count > 1 Then Exit Sub '複数セル選択を除外
　　If Target.Column <> 1 Then Exit Sub 'A列以外を除外
　　If Target.Value = "" Then Exit Sub '空白セルを除外
　　On Error Resume Next
　　tmp = objIE.Name 'IEが起動しているかチェック(.Nameプロパティ取得できたらOK）
　　If Err.Number <> 0 Then　'エラーなら起動していないので起動する。
　　　　Set objIE = CreateObject("InternetExplorer.Application")
　　End If
　　On Error GoTo 0
　　With objIE
　　　　.Navigate Target.Text
　　　　.Visible = True
　　　　Do While .Busy = True
　　　　　　DoEvents
　　　　Loop
　　End With
End Sub

ほんとなら、ページが存在しないと自動的にB列に丸をつけられればいいのですが,ページが無いという判定をどうすればよいのか思いつきません。

この回答へのお礼

ご回答ありがとうございます。

ちょっと、思っていたのと違いました。

グーグルに登録されているページというのは
グーグルにキャッシュされていて検索した時に
そのURLがグーグルのデータベースに載っているかどうかです。

もし、登録されていなければ、URLを検索しても

「http://～.comに一致する情報は見つかりませんでした。」

と表示されます。

でも、ソースを書いていただきありがとうございました。

お礼日時：2010/12/21 17:37

No.3 回答者： Wendy02 回答日時： 2010/12/21 21:38

>IEを開いてgoogoleのページでコピペで調べているのです

少し確認させてほしいのですが、Googleの「ページ」というのは何ですか？調べると、100ページはないはずです。Googleにページというのは言葉は出てきますが、70ページを越えた頃から怪しくなります。それ以上は、出せないというメッセージが出てきます。

一体、何をどう調べているのか教えてください。

件数ではいけないのですか？　以下は、約何件と出てくる部分を取り出したものです。

>Ｂ列には登録されている場合は「○」をつけ、登録されていない場合は「×」と記入しています。

登録されていない、という意味はなんですか？
例：$%%#%$#
という言葉では確かに出てきませんが、ほとんどはヒットするはずです。
よほどおかしな言葉ではない限りは、ヒットするはずです。

　A列　　B列　　C列
エクセル　○　8,600,000
ワード　　○　64,300,000
MS-Office　○　25,100,000
クラウド　○　20,300,000
オフコン　○　　　61,500
$%%#%$#　　×

また、本来は、10件以下とかは、危うい内容だということになります。

なお、質問では、環境が書かれていませんが、今回は、特別で、Excel, OS, IEなどのバージョンを一応、明示してください。ただし、OS が、Mac の場合は、おそらくこちらでは、コードは提示しても、動かない可能性があります。

もちろん、こちらでは、IEオートメーションは使いませんが、Googleでは、Header に、表示してあげないと、エラーが発生するようです。別にウソを入れても関係ないのですが、一応、念のためということで、教えてください。

また、検索用語は、どんなものを入れているのでしょうか？

通信環境やPCのパワーにもよりますが、600件でも、10分程度で終わるはずです。

No.4 回答者： Wendy02 回答日時： 2010/12/21 21:44

#3で、質問を読み間違えました。

単語を調べるのだと勘違いました。
しかし、URLを登録しているという意味が返って良く分かりません。
単に、URLがヒットするかどうかの問題ではありませんか？
なぜ、Google が関係してくるのか、ページが関係するのか、分かっていません。

No.5 回答者： ki-aaa 回答日時： 2010/12/22 08:42

試してみて

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Web_check()
Dim sss As String
Dim ie As Object
Dim i As Long

With ThisWorkbook.Sheets("Sheet1")

.Range("A2") = "http://oshiete.goo.ne.jp/qa/6398307.html" 'テストが終わったら削除する
.Range("A3") = "http://oshiete.goo.ne.jp/qa/16398307.html" 'テストが終わったら削除する

Set ie = CreateObject("InternetExplorer.application")
ie.Visible = True

For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
ie.Navigate ("http://www.google.co.jp/")
Do Until ie.busy = False
Sleep 100
DoEvents
Loop

ie.Document.all.q.Value = .Range("A" & i)
ie.Document.all.btnG.Click
Do Until ie.busy = False
Sleep 100
DoEvents
Loop

sss = ie.Document.body.innerHTML

Sleep 10000 'テストが終わったら削除する

If InStr(sss, "一致する情報は見つかりませんでした") Then
.Range("B" & i) = "xxxxxx見つかりませんでした。"
Else
.Range("B" & i) = "oooooo見つかりました。"
End If

Next i

End With

ie.Quit
Set ie = Nothing
End Sub

皆さんへの補足を見て仕上げましたが、
この作業にどういう意味が有るか解りませんでした。

この回答へのお礼

回答ありがとうざいます。

今、20ぐらいのURLを試しにやってみたのですが、
いい感じです。感激です。

あと気になる事が２つ程あるので質問させてください。

質問１
仮にまとめて、1000以上とかやる場合にグーグルの方で
制限がかからないかちょっと心配です？
10件検索したら30秒は休ませるなんてことができたらいいのですが・・・

質問２
今ある600ぐらいのURLでは、途中で抜けているURLがいくつかあります。
もし、空白があったらそこは検索しないで飛ばすなんてことはできないでしょうか？

大変、わがままな質問ですが、教えてただけると本当に助かります。

よろしくお願いします。

お礼日時：2010/12/22 11:30

No.6 回答者： ki-aaa 回答日時： 2010/12/22 13:38

補足、ありがとうございます。

質問１
　仮にまとめて、1000以上とかやる場合にグーグルの方で
　制限がかからないかちょっと心配です？
　10件検索したら30秒は休ませるなんてことができたらいいのですが・・・

>Sleep 10000 'テストが終わったら削除する
　　↓
if (i Mod 10) = 9 then sleep 30000　'10処理するごとに30秒休む

質問２
　今ある600ぐらいのURLでは、途中で抜けているURLがいくつかあります。
　もし、空白があったらそこは検索しないで飛ばすなんてことはできないでしょうか？

>For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
>ie.Navigate ("http://www.google.co.jp/")
　　↓
　For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
　if .Range("A" & i) <> "" then
　ie.Navigate ("http://www.google.co.jp/")


>End If
>
>Next i
　　↓
　End If
　End If
　Next i

それから、テストが済んだら次の行は削除してもいいかも

ie.Visible = True

この回答へのお礼

回答ありがとうございました。
昨日まで手作業をやていたのがうそみたいです。
いろいろ書いていただき本当にありがとうございました。

お礼日時：2010/12/22 17:55

No.7 回答者： Wendy02 回答日時： 2010/12/22 14:07

コメントは、次の書き込みの最後

二面に続けて書きます。

'標準モジュール
Private Const SKEY As String = "http://www.google.co.jp/search?hl=ja&q="
Public Sub GoogleCheckers()
Dim c As Range
Dim buf As String
Const qt As String = ""
For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
　If c.Value <> "" Then
　　Application.ScreenUpdating = False
　　buf = UrlEncode(c.Value)
　　buf = SKEY & buf
　　ItemCehck buf, c
　　Application.ScreenUpdating = True
　End If
Next
End Sub

Private Sub ItemCehck(ByVal strURL As String, iRng As Range)
　　Dim rng As Range
　　Dim objHTTP As Object
　　Dim i As Long, j As Long
　　Dim c As Variant
　　Dim httpLog As String
　　Dim msgbuf As Variant
　　Dim LimitNum As Long
　　On Error GoTo ErrHandler
　　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　　
　　objHTTP.Open "GET", strURL, False
　　objHTTP.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-JA; rv:1.9.2.12)"

　　objHTTP.Send
　　If Err.Number = 0 Then
　　　　If objHTTP.Status = 200 Then
　　　　　　httpLog = objHTTP.ResponseText
　　　　　　Call ContentsCheck(httpLog, iRng)
　　　　ElseIf objHTTP.Status >= 400 Then
　　　　　iRng.Offset(, 1).Value = "アクセスエラー"
　　　　End If
　　Else
　　　 iRng.Offset(, 1).Value = "?"
　　End If
　　Exit Sub
ErrHandler:
　　　　iRng.Offset(, 1).Value = "不明"
End Sub
Private Sub ContentsCheck(httpLog As String, rng As Range)
　Dim i As Long, j As Long
　Dim buf As String
　Const STXT As String = "検索オプション</a></div><div><div id=resultStats>"
　i = InStr(1, httpLog, STXT, 1)
　If i > 0 Then
　　buf = Mid(httpLog, i + Len(STXT), 50)
　　j = InStr(1, buf, "件<nobr>", 1)
　　buf = Mid(buf, 1, j)
　End If
　　If CLng(Val(buf)) > 0 Then
　　　rng.Offset(, 1).Value = "○"
　　　rng.Offset(, 2).Value = Val(buf)
　　Else
　　　rng.Offset(, 1).Value = "×"
　　End If
End Sub

'次に続く

No.8 ベストアンサー 回答者： Wendy02 回答日時： 2010/12/22 14:35

Private Function UrlEncode(ByVal sText As String) As String

Dim buf As String
　　If Len(sText) = 0 Then Exit Function
　　With CreateObject("ScriptControl")
　　　　.Language = "JScript"
　　　　buf = .CodeObject.encodeURI(sText)
　　　　buf = Replace(buf, ":", "%3A", , , 1)
　　　　buf = Replace(buf, "/", "%2F", , , 1)
　　　　UrlEncode = buf
　　End With
End Function

#3,4 の回答者です。私に答えないなら、もう、ご質問者さんに対して何も言いませんので、こちらの思惑で書かせていただくことにします。こちらでは成功していますから、特に問題はないはずです。IEオートメーションを使っている方には、今回のコードが参考になれば、幸いです。環境の違いなどの差は一切考慮しません。

上記のUrlEncode関数は、ほとんど利用価値はありませんが、もともとは単語を調べるためのものです。Quotation Mark("")で囲む必要かと思いましたが、差が出ませんでした。汎用性を残すために、これは使ったほうがよいです。ただ、URLEncode関数は、詳しい検討はなされていません。

本格的に使用する場合は、参照設定をしてください。そちらのほうが速いです。ItemCehckサブルーチンのobjHTTPオブジェクトは解放するコードが入っていません。本来は、モジュール・スコープでオブジェクトを置き、GoogleCheckers側の最後で解放するのがよいです。ESC等で途中で止めても弊害はないようです。

こちらの検索は、IEオートメーションは使ってはいませんが、IE8, Excel2003, Windows XP SP3ですが、RequestHeaderは、標準的な環境を使いました。開発ツールのDebugBurは必須かもしれません。ただ、ハッキングツールの一種として扱われているかもしれません。詳しく知りたい方は、「Webスクレイピング」で検索してみるとよいです。

実験結果として、Gooサイトでの個別のURLの一覧検索で、100件(#6400060～)で、およそ、2分以内で完了しました。ヒット32個(B列)　最高ヒット数3(C列）A列にURLを置きました。600個でも可能なはずです。ただし、サーバーからストップ掛かる時は、確か、503とかのエラーが返るはずです。

この回答へのお礼

回答ありがとうございました。
早速試させて頂きました。
スピードの速さに驚きました。
昨日まで、手作業で行っていたため、このような事が出来て本当に感謝いたします。
今回はいい勉強をさせていただきました。

ありがとうございます！

お礼日時：2010/12/22 17:50