エクセルでスクレイピング 自動化
今回はスクレイピングでクリックポストのお問い合わせを自動化しましたので記事にしたいと思います。
クリックポストのお問い合わせサービス、番号入力して配達状況をウェブサイトで確認するというものなんですが、関数を使ってある程度までは簡単に出来るようにしていました。
しかし、手動で行う部分も少なくはなかったので少し面倒くさいって思っていました。そもそも、発送した後はそんなことしないよ、って言われる方も多いかと思います。
以前、発送してから到着までどれくらい日数がかかるのかを調べていた時に、宛名情報不十分とのことで返送されているのをみつけ、確認したら番地の記入漏れがわかりました。代替えの商品があったのですぐに再発送で対応しましたが、返送品が届いてからの対応だと配達予定日を過ぎてしまうことになるので、これでは評価に悪い影響がでてしまう可能性があります。
ミスがなければあまり必要性がないのですが、スクレイピングが出来れば自動的に行えるようでしたので今回作成しました。
Sub BEST3() 'お問い合わせ自動
Application.ScreenUpdating = False
Windows("クリックポストまとめ申込マクロVER2.xlsb.xlsm").Activate
Sheets("クリックポストまとめ申込マクロ").Select
Dim X As String
Dim Y As Variant
Dim G As String
G = 1
Dim Z As Long
Dim dtToday As Date
Dim dtYesterday As Date
dtToday = Date '今日の日付を取得
dtYesterday = DateAdd("D", -1, dtToday) '"日付"を単位として-1"日"します
' 問合せ番号の最終行の取得
Z = Cells(Rows.Count, 10).End(xlUp).Row
Do Until dtYesterday = Y
Windows("クリックポストまとめ申込マクロVER2.xlsb.xlsm").Activate
Sheets("クリックポストまとめ申込マクロ").Select
X = Cells(Z, 10)
Y = Cells(Z, 9)
If G = 7 Then ´作成時無限ループ防止のために付加したもの
GoTo AA
Else
End If
If dtYesterday = Y Then
GoTo AA
Else
GoTo BB
End If
BB:
Sheets("sheet1").Select
Worksheets("Sheet1").Cells.Clear
'IEの起動
Dim objIE As Object
Set objIE = GetObject("", "InternetExplorer.Application")
objIE.Visible = True
objIE.Navigate "https://trackings.post.japanpost.jp/services/srv/search/direct?reqCodeNo1=" + X '日本郵便で問合せ番号”X”を検索する
' このURLを任意に変更
' ページの表示完了待ち。
While objIE.readyState <> 4 Or objIE.Busy = True
DoEvents
Wend
On Error Resume Next '値がないとエラーになっちゃうので、エラー回避用
i = 1 '開始行を指定
L = 0
J = objIE.Document.all.Length '要素の数を調べる
Cells(i, 1).Value = "No"
Dim B As Object
For Each B In objIE.Document.getElementsByTagName("tr")
For L = 0 To 10 '書き出す行数を指定
Cells(i, L + 1) = B.Children(L).innerText
Next
i = i + 1
'ステータスバーに進行状況を表示
Application.StatusBar = i & "/" & J
Next
On Error GoTo 0
Sheets("sheet1").Select
Dim m As Variant
Dim k As Variant
k = "お届け先にお届け済み" '配達状況の参照
m = Cells(9, 2)
If m = k Then
GoTo DD
Else
GoTo EE
End If
EE:
Z = Z - 1
G = G + 1
Loop
DD:
Sheets("クリックポストまとめ申込マクロ").Select
Worksheets("クリックポストまとめ申込マクロ").Range(Cells(Z, 10), Cells(Z, 1)).Rows.Delete Shift:=xlUp '不要な行を削除
Sheets("sheet1").Select
GoTo EE
AA:Cells.WrapText = False
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
スクレイピング部分以外は、人により条件が違いますので自分仕様に変更する必要があります。
それでは、また次回に!ありがとうございました。