おつかれさまです。

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

2018年5月14日

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

前回、クロネコヤマトの宅急便でおなじみのヤマト運輸の荷物お問い合わせを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をダウンロードしてください。直すのが面倒で。

SAGAWA


'  ***処理確認***
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＾＾)"

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 "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・マクロ・サンプル・フリーソフト

がんばりましょう。

VBA（マクロ）,SAMPLE付

Posted by master