前回、クロネコヤマトの宅急便でおなじみのヤマト運輸の荷物お問い合わせをexcelで作ってみましたが、佐川急便と郵便局も作ってみました。
【背景】
個人のかたは、1件ずつの宅急便伝票番号検索しますよね。会社で荷物を発送している場合、まとめて大量に検索したいことってありませんか？
B2クラウドとかで出荷していると、ある程度の追跡ができるのですが、ちょっと使いづらいです。自分も以前、メール便（今はDM便）1000通の配達状況を調べなければならない事があり、そのときにグぐって作成したのが始まりです。後にHPの構造が変わってしまい放置していたのを、再構築しています。
問い合わせ番号を網羅していないので検証は終わっていませんが、多分使えると思います。
※SAGAWA、JPとも出荷データが無い為、検証終わってません。
※フリーソフトと言うと恥ずかしいですが、勉強にどうぞ。ただ、責任は取れませんのでよろしく
EXCEL（2018/9/09修正）：Sample_4V4.xlsm
EXCEL（2018/10/30修正）：Sample_4V5.xlsm
UPファイル間違えていました。失礼。
EXCEL（2018/10/30修正）：Sample_4V6.xlsm
EXCEL（2020/05/10修正）：Sample_4V7.ZIP
取扱局を追加しましたが、テスト用の伝票データが無いのでうまく動くか分かりません。
何かあればコメント入れていただければ、なるべく対応したいと思います。
EXCEL（2022/04/07修正）：Sample_4V8
検証用の伝票番号が無いので検証はしてません。また、IEが2022/6月で終わりアナウンスが出てます。使えなくなるかもです。
【注意
・このEXCELは自由にご使用いただいて結構ですが、使用による損害等は一切受けませんのでご了承ください。
・各ホームページの構造が変わると修正が必要となります。
・パソコンの環境によって、動かない、遅い、エラーになる等あります。
・マクロの中に簡単な説明が書いてありますので、ご参考にください。
【内容】はhttps://www.bookservice.jp/2018/05/10/post-725/と同じです
|
Excel VBAでIEを思いのままに操作できるプログラミング術 Excel 2013／2010／2007／2003 [ 近田伸矢 ]
|
' ***処理確認***
MSG_FLG = MsgBox("準備OKですか？", vbYesNo)
If MSG_FLG = vbNo Then
Exit Sub
End If
'######## C:F クリア #########
Sheets("sagawa").Select
Columns("D:G").Select
Selection.ClearContents
Range("A1").Select
Set set_data01 = Worksheets("sagawa").Range("A2")
set_data01.Offset(-1, 3).Value = "検索/伝票番号"
set_data01.Offset(-1, 4).Value = "更新日"
set_data01.Offset(-1, 5).Value = "再配希望日"
set_data01.Offset(-1, 6).Value = "配達状況"
CNT02 = 0
Do Until set_data01.Offset(0, 0).Value = ""
'######### 宣言
Set IEOPEN = CreateObject("InternetExplorer.Application")
IEOPEN.Visible = True
'######### sagawa問い合わせをダイレクトにIEでopen
IEOPEN.navigate "http://k2k.sagawa-exp.co.jp/p/web/okurijosearch.do?okurijoNo=" & set_data01.Offset(0, 1).Value
'######### 1秒待つ
' waittime = Now + TimeValue("00:00:01")
' Application.Wait waittime
'######### IEの起動を待つ
CNT01 = 0
Do While IEOPEN.Busy = True Or IEOPEN.readyState <> 4
DoEvents
Application.Wait (Now + TimeValue("00:00:02"))
CNT01 = CNT01 + 1
If CNT01 >= 10 Then
'ページの再読み込み(リフレッシュ)
IEOPEN.Refresh
CNT01 = 0
End If
Loop
'######### 1秒待つ
' waittime = Now + TimeValue("00:00:01")
' Application.Wait waittime
If InStr(IEOPEN.document.body.innerHTML, "再配達受付") > 0 Then
FLG01 = "1"
Else
FLG01 = "0"
End If
'######### 各データクラスの一件目を取込む ※状態は3件目から 構造による
If FLG01 = "1" Then
wct = IEOPEN.document.getElementsByClassName("state")(0).innerText
Else
wct = IEOPEN.document.getElementsByClassName("state2")(0).innerText
End If
whiduke = IEOPEN.document.getElementsByClassName("nowrap")(3).innerText
saihai = IEOPEN.document.getElementsByClassName("nowrap")(4).innerText
wdenpyo = IEOPEN.document.getElementsByClassName("nowrap")(1).innerText
'######### 取込んだデータをexcelに貼り付け ※分かりやすいように分けています。
set_data01.Offset(0, 3).Value = wdenpyo
set_data01.Offset(0, 4).Value = whiduke
set_data01.Offset(0, 5).Value = saihai
set_data01.Offset(0, 6).Value = Replace(wct, vbLf, "")
'######### ie close ※溜まらないように
IEOPEN.Quit
Set IEOPEN = Nothing
CNT02 = CNT02 + 1
Application.StatusBar = "取込み開始 >" & CNT02 & " 件"
'######### 念のため
CNT02 = CNT02 + 1
If CNT02 > 500 Then
MsgBox ("STOP 500ken あとで IEキャッシュクリアしてください")
CNT02 = 1
End If
'######### 次の行
Set set_data01 = set_data01.Offset(1, 0)
Loop
MsgBox ("終了")
Application.StatusBar = "処理終了．．．．(v＾＾)"
' ***処理確認***
MSG_FLG = MsgBox("準備OKですか？", vbYesNo)
If MSG_FLG = vbNo Then
Exit Sub
End If
mySheetName001 = "JP"
'######## C:F クリア #########
Sheets(mySheetName001).Select
Columns("D:K").Select
Selection.ClearContents
Range("A1").Select
Set set_data01 = Worksheets(mySheetName001).Range("A2")
set_data01.Offset(-1, 3).Value = "●検索/伝票番号(JP未対応)"
set_data01.Offset(-1, 4).Value = "更新日"
set_data01.Offset(-1, 5).Value = "配達状況"
CNT02 = 0
Do Until set_data01.Offset(0, 0).Value = ""
'######### 宣言
Set IEOPEN = CreateObject("InternetExplorer.Application")
IEOPEN.Visible = True
'######### yuubin問い合わせをダイレクトにIEでopen
IEOPEN.navigate "http://tracking.post.japanpost.jp/service/singleSearch.do?org.apache.struts.taglib.html.TOKEN=&searchKind=S002&locale=ja&SVID=&reqCodeNo1=" & set_data01.Offset(0, 1).Value
'######### 1秒待つ
' waittime = Now + TimeValue("00:00:01")
' Application.Wait waittime
'######### IEの起動を待つ
CNT01 = 0
Do While IEOPEN.Busy = True Or IEOPEN.readyState <> 4
DoEvents
Application.Wait (Now + TimeValue("00:00:01"))
CNT01 = CNT01 + 1
If CNT01 >= 10 Then
'ページの再読み込み(リフレッシュ)
IEOPEN.Refresh
CNT01 = 0
End If
Loop
'######### 1秒待つ
' waittime = Now + TimeValue("00:00:01")
' Application.Wait waittime
'######### 検索結果チェック
If InStr(IEOPEN.document.body.innerHTML, "お問い合わせ番号が見つかりません") > 0 Then
Application.StatusBar = "お問い合わせ番号が見つかりません。...ですって！！"
set_data01.Offset(0, 3).Value = ""
set_data01.Offset(0, 4).Value = ""
set_data01.Offset(0, 5).Value = "お問い合わせ番号が見つかりません。"
GoTo skip1
End If
'######### 指定クラスの下位要素を抽出
' OBJB = IEOPEN.Document.getElementsByClassName("tableType01 txt_c m_b5")(0).innerHTML
OBJA = IEOPEN.document.getElementsByClassName("tableType01 txt_c m_b5")(1).innerHTML
'
'######### OBJAに抽出したテキストを検索
'######### 頭からw_150を調べて、一番最後を抽出
CNT03 = 1
EXITFLG1 = "0"
Do Until EXITFLG1 = "1"
CNT03 = InStr(CNT03, OBJA, "w_150")
If CNT03 <> 0 Then
CNT04 = CNT03
CNT03 = CNT03 + 1
Else
EXITFLG1 = "1"
CNT05 = InStr(CNT04, OBJA, "</td>")
CNT04 = CNT04 + 19
End If
Loop
CNT06 = CNT05 - CNT04 '### 文字数
set_data01.Offset(0, 5).Value = Mid(OBJA, CNT04, CNT06)
'######### OBJAに抽出したテキストを検索
'######### 頭からw_120を調べて、一番最後を抽出
CNT03 = 1
EXITFLG1 = "0"
Do Until EXITFLG1 = "1"
CNT03 = InStr(CNT03, OBJA, "w_120")
'
If CNT03 <> 0 Then
CNT04 = CNT03
CNT03 = CNT03 + 1
Else
EXITFLG1 = "1"
CNT05 = InStr(CNT04, OBJA, "</td>")
CNT04 = CNT04 + 19
End If
Loop
CNT06 = CNT05 - CNT04 '### 文字数
set_data01.Offset(0, 4).Value = Mid(OBJA, CNT04, CNT06)
skip1:
'######### ie close ※溜まらないように
IEOPEN.Quit
Set IEOPEN = Nothing
CNT02 = CNT02 + 1
Application.StatusBar = "取込み開始 >" & CNT02 & " 件"
'######### 念のため
CNT02 = CNT02 + 1
If CNT02 > 500 Then
MsgBox ("STOP 500ken あとで IEキャッシュクリアしてください")
CNT02 = 1
End If
'######### 次の行
Set set_data01 = set_data01.Offset(1, 0)
Loop
MsgBox ("終了")
Application.StatusBar = "処理終了．．．．(v＾＾)"
宅急便・調査・検索・EXCEL・マクロ・サンプル・フリーソフト
View Comments
佐川急便の送り状確認、とても役に立っています！
ありがとうございます。
一点お願いがあります。
佐川急便の「ステータス表示」で
下記のようなステータスの場合、プログラムが止まってしまいます。（現状確認できるのは、２通り）
持戻り
（再配達受付）
ご不在
（再配達受付）
もしご教示いただければ幸いです。
（当方、VBA初心者……です）
よろしくお願いします。
ヤマト運輸以外は全ステータスが見れていないの抜けていると思われます。
そのステータスのソースか、対象の番号を頂けますでしょうか？※番号は流れで変わってしまうので再度必要になるかもしれません。
半分趣味でやっているのでご期待にそえるか分かりませんが、宜しくお願い致します。
JPの検索大変使えております。このようなシステムを探していました。
もし可能であればご教授願いたいのですが、当方約数千件のデータを取り扱っているため
個別検索だと時間が大幅にかかってしまいます。
連続番号検索を使用できると非常に助かりますが、可能でしょうか。
当方、VBAの初心者でいろいろな手法を勉強しているところです。
よろしくお願いします。
yanagi さん
コメントありがとうございます。
連続番号検索の件ですが、可能だとは思いますがJPの仕様が分からないので簡単かどうかは、申し訳ありませんが、分からないです。
また、リスクとしてホームページの仕様が変更になったとき、複数検索の修正は時間がかかる可能性があります。
※実はヤマトは10件毎で作ったことがあったのですが、ホームページの構造が全く変わったため、当時の自分には対応できなかったので1件毎で作成しています。
とりあえず、時間があるとき見てみますが、JPの詳細パターンが分からないため、難しいかもしれません。
ご存じだとは思いますが、有料ソフトでは対応しているものもあると思います。
無料かどうか分かりませんが、郵便追跡システムの追跡データ提供サービスというものもあるようです。
コメント失礼いたします。
日本郵便のパターンで質問です。
w_150「配送履歴の」頭から,,,を改良して、最終取扱局を表示できるようにしたく、w_150をw_105に書き換えたところ、引数が誤っているとはじかれてしまいます。
class扱いであるのが原因かな？と考えているのですが、解決の方法はありますでしょうか。
よっとさん、コメントありがとうございます。
ずいぶん前に作ったので記憶が曖昧なんですが、JPのHTMLの構造だとW_105(class)の数が一定でない為、結構面倒で対応しなかったと思います。
見てみましたが、W_150は1行に1個ですが、W_105は1行に3個あり、規則的なら問題ないのですが他の場所でも使っています。
自分のマクロは、最後のW_150を探して張り付けてますが、W_105の最後は「お問い合わせ窓口局」の項目にもあるので、工夫が必要かと思います。
例）W_150の何個目か、抑えておき、W_105を3で割った数がその抑え多数になったらテキストを分解して抽出。
※合ってるか自信が無いですがこんな感じです。
コメント失礼いたします。
会社内にて便利に使用させていただいております。その中で佐川急便での送り状NO追跡ですが、佐川急便のホームページが一新したのか、複数番号での追跡が出来なくなっております。最初の１件分の画面で止まってしまいます。主様にて再度ご検証いただければ幸いでございます。当方excelvbaはまだまだ初心者にていまいち解りかねております。
大変お手数ではございますが、よろしくお願い申し上げます。
amncom1437さん
暇つぶしで作ったのですが多少は役に立っていたのですね。
現在自分は前職から離れてしまい、荷物番号が無いため検証できないです。
amncom1437さんで番号を開示いただくのが問題なければ、見る事は出来ますが、必ず修正できるかお約束はできません。EXCELのマクロで取得しているので構造上むずかしい場合もございます。
また、自分も空いた時間で趣味程度で作ったものなので、どれぐらい時間がかかるかもお約束できません。
では。