【エクセル】ハイパーリンク先のチェック

質問

【エクセル】ハイパーリンク先のチェック

いつも、ご回答いただきありがとうございます。

現在、エクセル内に２０００個弱のハイパーリンクがあります。

そのハイパーリンク先のホームページが実際にあるのかどうか、
リンク切れチェックをしたいのですが、手動＆目視でやるには時間が
かかり過ぎてしまいます。

マクロで自動的にチェックできるスクリプトなどは無いでしょうか？

ご存知の方がいらっしゃいましたら、ご助言いただけないでしょうか？
よろしくお願いします。

回答No.4

mitarashi · ベストアンサー

#1～#3です。
直接の回答になっておりませんが、IEのbookmarkからURLを抽出して試行してみました。その結果、訳の分からない実行時エラーで止まったり、12000番台のWinInetのエラーが出てみたりと、なかなか奥が深いです。下記コードで、200番台を戻さないURLはリンク切れと判断してよいかと思います。当方のbookmarkでは正常につながるものは、すべて200を返しました。ほかは0（実行時エラー）または12000番台のエラーが多く、404と503がそれぞれ一個でした。（URL100個中）なお、キャッシュされますので、二回目以降の実行時は配慮が必要です。
Sub test()
Dim targetRange As Range, myCell As Range
Dim myURL As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set targetRange = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For Each myCell In targetRange.Cells
myURL = myCell.Hyperlinks.Item(1).Address
'必要によりキャッシュ削除　下記URL参照
'http://hanatyan.sakura.ne.jp/vbhlp/DelUrl.htm
myCell.Offset(0, 1).Value = checkUrlLink(myURL)
Next myCell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Private Function checkUrlLink(myURL As String) As Long
Dim req As Object

Set req = CreateObject("Microsoft.XMLHTTP")
req.Open "GET", myURL, False
On Error Resume Next
req.send
On Error GoTo 0
If Err.Number = 0 Then
checkUrlLink = req.Status
Else
checkUrlLink = 0
End If
Set req = Nothing
End Function

参考URL：

http://support.microsoft.com/kb/193625/ja

お礼

ご回答頂きありがとうございます。
お礼が遅くなり申し訳ありません。

まさしくこれを求めていました！使わせていただきます。

ありがとうございました＾＾

回答No.3

mitarashi

#1&#2です。後学のために動かしてみました。XL2010でやっていますが、XL2000の知識で組んでいます(^^;)
A列にA1からハイパーリンクが入っているとします。B列にチェックした結果を戻します。False=リンク切れ。
失礼してOKWaveの質問のURLを100個作成して試験してみましたが、約2分10秒かかりました。（11g無線LAN環境）やってみて分かった事は、OKWaveは質問が存在しなくても、「質問がみつからない」というhtmlを戻すので、Falseにならないという事です。という事で、本当の試験はできておりませんが、ご参考まで。
Sub test()
Dim targetRange As Range, myCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set targetRange = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For Each myCell In targetRange.Cells
If checkUrlLink(myCell.Hyperlinks.Item(1).Address) = True Then
myCell.Offset(0, 1).Value = True
Else
myCell.Offset(0, 1).Value = False
End If
Next myCell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Private Function checkUrlLink(myURL As String) As Boolean
Dim req

Set req = CreateObject("Microsoft.XMLHTTP")
req.Open "GET", myURL, False
req.Send
If Not (req.Status >= 200 And req.Status < 300) Then
checkUrlLink = False
Else
checkUrlLink = True
End If
End Function

お礼

ご回答いただき、ありがとうございます。
返事が遅くなり、申し訳ありませんでした。

さっそく、mitarashiさんのマクロを使わせていただきました。

まさしくこのようなマクロを求めていました（笑）

しかし、いくつか問題がありました。

リンク先が確実にあるものに関しては、問題がなかったのですが、
マクロ実行中に、このようなメッセージが出てマクロが止まってしまう事が
あります。なぜでしょうか？

○　オートメーションエラー
○　書き込みができません

mitarashiさんのマクロが原因ではない（私のデータだと・・・）と思いますが、
これはどのようにしたらよいのでしょうか？

ちなみに、このメッセージが出るURLに関しては、true、falseは入力されず、
空白のままになって、マクロが停止します。

初歩的な質問かもしれませんが、ご助言頂けないでしょうか？

よろしくお願いします。

回答No.2

mitarashi

#1です。
Microsoft.XMLHTTPを用いる例をみつけました。
HTTPサーバからクライアントに向けた応答コードで判別しているので、こちらの方がスマートですね。
http://www.excel.studio-kazu.jp/kw/20100729161514.html?t=185707
なお、HTTPサーバの戻すコードの解説は下記にあります。
req.Status >= 200 And req.Status < 300　の意味が理解できます。
http://www.h2.dion.ne.jp/~micased/http.html

回答No.1

mitarashi

IE6なら下記のNo.2のコードが使えると思いますが、IEのバージョンが新しいとひとひねりが必要らしいです。当方インストールするつもりはないので、検証できません。あしからず。
文中のリンク先（長いので探し出すのに苦労しますが）ではWebbrowserを用いる例が載っていますが、試してみておりません。ご参考まで。
http://okwave.jp/qa/q4082853.html