解決済み

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

  • 困ってます
  • 質問No.5474619
  • 閲覧数2396
  • ありがとう数2
  • 気になる数0
  • 回答数2
  • コメント数0

お礼率 36% (4/11)

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

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

宜しくお願いします。

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

  • 回答No.1

ベストアンサー率 64% (66/102)

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

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
お礼コメント
fuyuhiko

お礼率 36% (4/11)

>kenpon24さん

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

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

有難うございました!
投稿日時 - 2009-11-25 15:09:15
Be MORE 7・12 OK-チップでイイコトはじまる

その他の回答 (全1件)

  • 回答No.2

ベストアンサー率 57% (3570/6233)

こんにちは

私はやったことがないですが、そういえば、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
お礼コメント
fuyuhiko

お礼率 36% (4/11)

>fuyuhikoさん

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

有難うございます。
投稿日時 - 2009-11-25 15:12:07
AIエージェント「あい」

こんにちは。AIエージェントの「あい」です。
あなたの悩みに、OKWAVE 3,500万件のQ&Aを分析して最適な回答をご提案します。

関連するQ&A
このやり方知ってる!同じこと困ったことある。経験を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。
このQ&Aのテーマ

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する

特集


より良い社会へ。感謝経済プロジェクト始動

ピックアップ

ページ先頭へ