プロが教える店舗&オフィスのセキュリティ対策術

Excel VBAでリンク切れをチェックしたい。
図のように、リンク一覧からリンクを調べ、問題なければ「○」を表示し、リンク切れの場合は「×」を表示したいんですが、どんなプログラムを組めばよいですか?
よろしくお願いします。

「Excel VBAでリンク切れをチェック」の質問画像
gooドクター

A 回答 (2件)

誰もレスを付けないと思いましたので、こちらでも作りましたのでアップしておきます。


#1の方とは、少し意味が違う部分があるかと思います。

以前、ここの掲示板で出したことがあると思うのですが、もう見つかりません。

一応、今回は、自分用で作ってみました。プロバイダからクレームが付きそうな気がしましたが、実行してしまいました。常識の範囲でお使いください。あまり速くはありませんが、ハングはしませんでした。

リンク先のチェックは、838件を一気にチェックしてしまいましたが、これほどはやらないほうが良いかもしれません。100件やって休むとかしたほうが良いような気がします。

ユーザー定義関数の戻り値は、いくつかあります。ステータス200は、◯ですが、その他は、種類がいろいろありますので、×にせずに数値や文字にしました。基本的に、ステータスコードの200は、全部返しました。

数字については、ステータス・コード表をごらんになってください。
http://www.asahi-net.or.jp/~ax2s-kmtn/ref/status …

例:
404 サイトがなくなっています。
403 アクセス権限がないということですから、ログインしなければ分からないかもしれません。
他にも、いくつか種類が出てきます。
n.a と出るのは、サーバーが受け付けないものだと思います。

アンチウィルスソフトで、禁止区域に入った時は、メッセージが出てきました。しかし、そのままで続いていきます。
このマクロ使用中でも、スクロールは可能です。

場所は標準モジュールです。

''//--
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private objHTTP As Object
Sub Main_URLChecking()
  Dim c As Range
  Dim i As Long
  ''Microsoft WinHTTP Service, version 5.1 '参照設定する場合
  ''Set objHTTP=New winHttp.WinHttpRequest '
  For Each c In Range("B2", Cells(Rows.Count, 2).End(xlUp))
    If LCase(c.Value) Like "http://*" Then
      c.Offset(, 1).Value = CheckURL(c.Value)
      Sleep 200  'Wait を掛ける
      DoEvents   'ESCで離脱できるようにする。
    End If
  Next
   Set objHTTP = Nothing
End Sub
Function CheckURL(ByVal strURL As String) As Variant
  Dim num As Variant
  On Error GoTo ErrHandler
  If objHTTP Is Nothing Then
     Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
  End If
  objHTTP.Open "GET", strURL, False
  objHTTP.Send
  If objHTTP.Status = 200 Then
    CheckURL = "◯"
  Else
    CheckURL = objHTTP.Status
  End If
  Exit Function
ErrHandler:
  If Err() <> 0 Then
    CheckURL = "n.a"
  End If
End Function

''//--


なお、今度は、これを、ハイパーリンクのリストに反映しないといけないのかな?
    • good
    • 2
この回答へのお礼

ご回答ありがとうございます。
無事に処理することが出来ました。
マクロ使用中でもスクロール出来るのはすごく良かったです。
大変助かりました。
ありがとうございました。

お礼日時:2016/04/06 15:00

できました。


標準モジュールに以下のコードを記載し、
B2セルから下にチェックしたいURLを並べて実行してください。
URLはハイパーリンクでなくても構いません。

Sub test()
Dim req
Dim MyUrl As String
Dim cnt As Long
Dim i As Long
Dim MyRng As Range


Set req = CreateObject("Microsoft.XMLHTTP")
cnt = Cells(2, 2).CurrentRegion.Rows.Count
For i = 1 To cnt
Set MyRng = Range("B2").Cells(i, 1)
MyUrl = MyRng.Value

req.Open "GET", MyUrl, False
req.Send
' Debug.Print req.Status
If Not (req.Status >= 200 And req.Status < 300) Then
MyRng.Cells(1, 2).Value = "×"
Else
MyRng.Cells(1, 2).Value = "◯"
End If
Next i
End Sub


参考にさせていただいたページ
http://www.excel.studio-kazu.jp/kw/2010072916151 …
http://www.excel.studio-kazu.jp/kw/2005092716325 …
http://www.relief.jp/itnote/archives/excel-vba-c …
「Excel VBAでリンク切れをチェック」の回答画像1
    • good
    • 4
この回答へのお礼

ご回答ありがとうございます。
無事に処理することが出来ました。
大変助かりました。
ありがとうございました。

お礼日時:2016/04/06 14:58

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング