Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


224 / 75435 ←次へ | 前へ→

【80861】Re:web クエリの高速化
回答  γ  - 19/6/2(日) 20:31 -

引用なし
パスワード
   動作するものを一応作って見ました。

<<結果シート>>のレイアウト
  A列  B列    C列     D     E   F
1 コード 保険者番号 保険者名  郵便番号  住所  電話番号
2
3

・予め設定されているA列の保険者用のコードを読み込んで使用します。
・B列以下の列に、サーバーから取得結果を書き込みます。
・同一であることを念のため確保するため、B列はA列と同じものを書き込みます。

-----------------
動作することを確認していますが、保証するものではありません。
また、スクレイピングに関しての責任は負いかねます。
データの著作権等について十分確認して下さい。

また、サーバーに連続してアクセスすると負荷が掛かり、
これを禁止するところもあります。
そこで、0.2秒の間隔を空けてアクセスするようにしていますが、
これは最低限守ってください。
(連続アクセスをした人が逮捕された"守口図書館事件"が有名です。
 検索してみてください。)

-----------------
なお、今後、「仕様の変更依頼等には一切応じる積もりはありません。」
予めご了解ください。

頻度がそう高いものではないのですから、3時間ですむなら、
今の簡潔なものでも十分と思います。

XMLHt■tpRequestと正規表現を使ったコードを以下に示します。

なお、エイチティーティーピーと言う単語が使用禁止になっていますので、
元に戻してから使用してください。("■"を""に置換すればよいでしょう)

Option Explicit

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

Dim re   As Object
Dim Match  As Object
Dim Matches As Object
Dim Ht■tpRequest As Object
Dim mat()  As String

Sub main()
  Dim ws   As Worksheet
  Dim s1   As String
  Dim s2   As String
  Dim s    As String
  Dim uri   As String
  Dim myText As String
  Dim k    As Long
  Dim lastRow As Long
  Dim kosu  As Long
  
  Dim t
  t = Timer
  
  Set Ht■tpRequest = CreateObject("MSXML2.XMLHT■TP.3.0")
  Set re = CreateObject("VBScript.RegExp")
  
  Set ws = Worksheets("結果")
  
  s1 = "ht■tp://hokeninfolist.main.jp/sp/dt"
  s2 = ".html"
  
  lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
  kosu = lastRow - 1
  ReDim mat(1 To kosu, 1 To 5) '一時保持用配列
  
  For k = 1 To kosu
    Sleep 200  ' サーバー負荷を考慮して、0.2秒間隔を空ける
    s = ws.Cells(k + 1, "A").Value
    uri = s1 & s & s2
    
    ' サイトからHTMLファイルを取得
    myText = getHT■TPText(uri)
      
    If myText <> "" Then
      'HTMLを解析して該当項目を取得
      Call setEachDataToMat(myText, k)
    Else
      '何もしない
    End If
  Next
  '結果をシートに貼付
  [B2].Resize(kosu, 5).Value = mat
  
  Debug.Print Timer - t
End Sub

Sub setEachDataToMat(myText As String, k As Long)
  Dim j As Long
  
  '保険者番号,保険者名,郵便番号,住所を取得し、配列matに書込む
  re.pattern = """dt"">(.*?)</div>"
  re.IgnoreCase = True
  re.Global = True
  Set Matches = re.Execute(myText)
  
  j = 1
  For Each Match In Matches
    mat(k, j) = Match.SubMatches(0)
    j = j + 1
    If j >= 5 Then Exit For
  Next
  
  '電話番号
  re.pattern = """dttel""><(?:.*?)>(.*?)</a>"
  Set Matches = re.Execute(myText)
  mat(k, 5) = Replace(Matches(0).SubMatches(0), "&nbsp;", "")
End Sub

Function getHT■TPText(uri As String) As String
  With Ht■tpRequest
    .Open "GET", uri, False
    .send
    'return codeが200でないとき(例:404該当無しなど)
    If Not (.Status >= 200 And _
        .Status < 300) Then
      getHT■TPText = ""
      Exit Function
    End If
    getHT■TPText = .responseText
  End With
End Function

46 hits

【80851】web クエリの高速化 よし 19/6/1(土) 2:10 質問[未読]
【80854】Re:web クエリの高速化 γ 19/6/1(土) 9:29 発言[未読]
【80858】Re:web クエリの高速化 よし 19/6/1(土) 19:45 質問[未読]
【80861】Re:web クエリの高速化 γ 19/6/2(日) 20:31 回答[未読]
【80862】Re:web クエリの高速化 γ 19/6/2(日) 21:14 発言[未読]
【80865】Re:web クエリの高速化 よし 19/6/3(月) 3:16 お礼[未読]
【80864】Re:web クエリの高速化 γ 19/6/2(日) 22:42 発言[未読]

224 / 75435 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free