EXCEL超初心者マクロ(4)-SAGAWA(佐川急便)とJP(郵便局)荷物お問い合わせ-

2018年6月21日EXCEL/ACCESS

クロネコヤマト(ヤマト運輸)SAGAWA(佐川急便)とJP(郵便局)荷物お問い合わせ(宅急便番号調査)作ってみた。

前回、クロネコヤマトの宅急便でおなじみのヤマト運輸の荷物お問い合わせをexcelで作ってみましたが、佐川急便と郵便局も作ってみました。

【背景】
個人のかたは、1件ずつの宅急便伝票番号検索しますよね。会社で荷物を発送している場合、まとめて大量に検索したいことってありませんか?
B2クラウドとかで出荷していると、ある程度の追跡ができるのですが、ちょっと使いづらいです。自分も以前、メール便(今はDM便)1000通の配達状況を調べなければならない事があり、そのときにグぐって作成したのが始まりです。後にHPの構造が変わってしまい放置していたのを、再構築しています。

問い合わせ番号を網羅していないので検証は終わっていませんが、多分使えると思います。
※SAGAWA、JPとも出荷データが無い為、検証終わってません。
※フリーソフトと言うと恥ずかしいですが、勉強にどうぞ。ただ、責任は取れませんのでよろしく

メインEXCEL(2018/5/28修正):Sample_4V3.xlsm

【注意
・このEXCELは自由にご使用いただいて結構ですが、使用による損害等は一切受けませんのでご了承ください。※フリーでご使用ください。
・各ホームページの構造が変わると修正が必要となります。
・パソコンの環境によって、動かない、遅い、エラーになる等あります。
・マクロの中に簡単な説明が書いてありますので、ご参考にください。

【内容】はhttps://www.bookservice.jp/2018/05/10/post-725/と同じです

 

 

以下、内容です。見づらいですがご容赦ください。ダウンロードするともう少し見やすいです。


SAGAWA

'  ***処理確認***
MSG_FLG = MsgBox("準備OKですか?", vbYesNo)
If MSG_FLG = vbNo Then
    Exit Sub
End If

'######## C:F クリア #########
Sheets("sagawa").Select
Columns("D:F").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 = "配達状況"

CNT02 = 0

Do Until set_data01.Offset(0, 0).Value = ""

  '######### 宣言
   Set IEOPEN = CreateObject("InternetExplorer.Application")
   IEOPEN.Visible = True

  '######### sagawa問い合わせをダイレクトにIEでopen
   IEOPEN.navigate "https://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: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
   
   
  '######### 各データクラスの一件目を取込む ※状態は3件目から 構造による
   wct = IEOPEN.Document.getElementsByClassName("state2")(0).innerText
   whiduke = IEOPEN.Document.getElementsByClassName("nowrap")(3).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 = wct
   
  '#########  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^^)"

JP(郵便局)

' ***処理確認***
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 "https://tracking.post.japanpost.jp/service/singleSearch.do? 
  org.apache.struts.taglib.html.TOKEN=&amp;searchKind=S002&amp;locale=ja&amp;SVID=&amp;reqCodeNo1=" &amp; 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 &lt;&gt; 4
      DoEvents
      Application.Wait (Now + TimeValue("00:00:01"))
      CNT01 = CNT01 + 1
      If CNT01 &gt;= 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, "お問い合わせ番号が見つかりません") &gt; 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

'######### 指定クラスの下位要素を抽出
   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 &lt;&gt; 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)
   
   

  '#########  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
skip1:
  '#########  次の行
   Set set_data01 = set_data01.Offset(1, 0)

Loop

MsgBox ("終了")
Application.StatusBar = "処理終了....(v^^)"

宅急便・調査・検索・EXCEL・マクロ・サンプル・フリーソフト

EXCEL/ACCESS

Posted by master