みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

EXCEL VBAでたくさんのURLの一覧からHTTPレスポンスコードを取得したい。

VBA初心者です。
EXCEL VBAでプログラミングの練習をしています。

シート名:一覧
URL記入セル:A1~A100
結果を記入するセル:B1~B100
があり、URL記入セルに入力されているURLにアクセスし
レスポンスコードを(404とか200とか)B列に書き出す
というのを実行できるコードの書き方を教えてください。
(1週間取り組んでいますがまだできません・・・)
サンプルコードを直接改定頂けると最高です。

宜しくお願いします。

投稿日時 - 2009-11-25 12:18:15

QNo.5474619

困ってます

質問者が選んだベストアンサー

こんな感じでしょうかね。たぶん。。。

Sub Sample()

  Dim i As Long
  Dim bottom As Long
  
  bottom = Range("A65536").End(xlUp).Row
  
  For i = 1 To bottom
    
    Range("B" & i) = GetWebStatus(Range("A" & i))
  
  Next i
  
End Sub

Function GetWebStatus(URL As String) As String

  Dim WinHttp As Object

  Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")

On Error GoTo INVALID

  WinHttp.Open "GET", URL, False
  WinHttp.send

  GetWebStatus = WinHttp.Status
  
  Set WinHttp = Nothing
  
  Exit Function
  
INVALID:
  GetWebStatus = "Invalid URL"
  
  Set WinHttp = Nothing
  
  
End Function

投稿日時 - 2009-11-25 13:15:35

お礼

>kenpon24さん

ご回答有難うございます。
一番早く解決できたのでBAにさせていただきます。

まだ、レベルが低すぎてソースコードの細かい部分が
理解できていませんが、書いていただいたコードを基に
学習していきます。

有難うございました!

投稿日時 - 2009-11-25 15:09:15

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

こんにちは

私はやったことがないですが、そういえば、Webサイトのあるなしを、Status で取得方法があるのだなって、言われて思い出しました。しかし、私が最初に考えたものは、#1さんとほぼイメージとしては同じなのですが、少し工夫をしてみました。

'-------------------------------------------

'Option Explicit
Dim objHTTP As Object 'モジュールの上部に置く
Sub CheckURL()
  Dim ret As Variant
  Dim c As Range
  On Error GoTo ErrHandler
  If objHTTP Is Nothing Then
    Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
  End If
  
  For Each c In Range("A1", Range("A2000").End(xlUp))
    If StrConv(c.Value, vbLowerCase) Like "http://*" Then
      c.Offset(, 1).Value = GetHttpHeader(c.Value)
    End If
  Next
ErrHandler:
  If Err.Number > 0 Then
   MsgBox Err.Number & " : " & Err.Description
  End If
  Set objHTTP = Nothing
End Sub
Function GetHttpHeader(ByVal strURL As String)
Dim ret As Variant
  ret = Empty
  On Error Resume Next
  objHTTP.Open "GET", strURL, False
  objHTTP.Send
   ret = objHTTP.Status
  On Error GoTo 0
  If ret <> 0 Then
   GetHttpHeader = ret
  End If
End Function

投稿日時 - 2009-11-25 14:26:46

お礼

>fuyuhikoさん

ご回答有難うございます。
まだ、レベルが低くてすんなりと違いを認識できていませんが
問題なく、解決できました!

有難うございます。

投稿日時 - 2009-11-25 15:12:07

あなたにオススメの質問