| |
動作するものを一応作って見ました。
<<結果シート>>のレイアウト
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), " ", "")
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
|
|
yamasan
- 19/6/5(水) 10:08 -
gan134
- 19/6/4(火) 22:10 -
マナ
- 19/6/4(火) 22:00 -
シンガリ
- 19/6/2(日) 21:33 -
