クロネコヤマト一括配送確認

その他

どうしてもクロネコの配送状況を一括で確認しなくてはならない状況だったので、ネットを駆けずり回ってエクセルのマクロのプログラムを編集・作成。
「マクロ起動でＩＥを立ち上げて入力→確認→繰り返し→Ａ列に番号がなくなるまで続ける。」

常に使えるかは不明です。
必要項目は・・・必要な人は自分で変えてください。
とりあえずシート3のA列に縦にコードを入れて、マクロ起動でシート4に結果を書き出すイメージで。

もしも、どなたかのコードサンプルにひっかかってしまって、削除要請が来たら消します。
以下、コードです。

−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−

Sub YAMATO_CHECK() 'IEテストする。

'出力されるシートを空白にする
Sheet4.Cells.Clear

'IEの起動と各種定数の宣言
Dim x As Integer, y As Integer '列と行カウンター
Dim n As Integer, i As Integer
Dim objIE As Object 'ＩＥオブジェクト参照用
Dim objTAG As Object '１つ１つ タグのオブジェクトを入れる
Dim strTNAME As String 'タグの名前を保存する
Set objIE = CreateObject("InternetExplorer.Application") 'オブジェクトを作成します。
objIE.Visible = True '可視、Trueで見えるようにします。

'処理したいページを表示します。
objIE.Navigate "http://toi.kuronekoyamato.co.jp/cgi-bin/tneko"

'ページの表示完了を待ちます。
While objIE.ReadyState <> 4 Or objIE.Busy = True '.ReadyState <> 4の間まわる。
DoEvents '重いので嫌いな人居るけど。
Wend

Dim ClmNo As Integer
Dim ClmNo2 As Integer
Dim ClmNo3 As Integer
Dim strClmNo As String

Do While Cells(ClmNo2 + 1, 1) <> ""

'項目(name=number01〜9)にセットする。

ClmNo = 0

Do While ClmNo <= 8
ClmNo = ClmNo + 1
ClmNo2 = ClmNo2 + 1
strClmNo = "number0" & ClmNo
objIE.Document.getElementsByName(strClmNo)(0).Value = Cells(ClmNo2, 1)
Loop

ClmNo3 = ClmNo2 + 1

objIE.Document.getElementsByName("number10")(0).Value = Cells(ClmNo3, 1)

'「お問い合わせ開始」を実行
objIE.Document.forms(0).submit

'ページの表示完了を待ちます。
While objIE.ReadyState <> 4 Or objIE.Busy = True '.ReadyState <> 4の間まわる。
DoEvents '重いので嫌いな人居るけど。
Wend

'6個目のTABLEタグから読みする
For n = 6 To objIE.Document.all.Length - 1
If objIE.Document.all(n).InnerText = "お問い合わせ伝票番号" Then Exit For
Next n

y = y + 1 '行カウンターを初期化(はじめの改行で＋1するので０から)
x = 0 '列カウンターを初期化(TR 改行時に初期化するのでいらないんだけど)

'Documentから.TagNameでTR TD THを判断して、結果(.InnerText)を別のシートに書き出す
For i = n + 1 To objIE.Document.all.Length - 1

strTNAME = objIE.Document.all(i).tagname 'タグの名前を変数へ保存

If strTNAME = "TR" Then 'TR行の開始なら
y = y + 1 '行開始なので 行カウンターを＋1
x = 0 '列を０(頭)初期化
End If

If strTNAME = "TH" Or strTNAME = "TD" Then 'TH見出し TDデータ
x = x + 1 '列カウンターを＋1
Sheet4.Cells(y + 1, x + 1) = objIE.Document.all(i).InnerText '.InnerTextをセットする
End If

If strTNAME = "TABLE" Then 'TABLEなら(次のテーブルが現れたら)
Exit For 'ループを強制的に抜けます
End If

Next i

'「クリア」を実行？→入力されている文字を消す
objIE.Document.forms(1).submit

'ページの表示完了を待ちます。
While objIE.ReadyState <> 4 Or objIE.Busy = True '.ReadyState <> 4の間まわる。
DoEvents '重いので嫌いな人居るけど。
Wend

ClmNo2 = ClmNo2 + 1

Loop

'---------------------------------------------------------------------------------------------
'チェックおわり
'---------------------------------------------------------------------------------------------

'IEを閉じる
objIE.Quit
Set objIE = Nothing

'列幅を20に変更
Sheet4.Columns("A:F").ColumnWidth = 20

'A行を削除
Sheet4.Range("A:A").Delete

'項目と空白の行を削除
Dim RwMax As Long 'データの最終行の行番号を保持する変数
Dim Rw As Long '現在処理中の行番号を保持する変数

'データの最終行の行番号を取得します。
RwMax = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row 'Ａ列においてデータが入っている一番下のセルの行番号

'最終行から１行目まで繰り返し処理をします。
'（行の削除を行なうため、下から上へと向かって処理します。）
Application.ScreenUpdating = False
For Rw = RwMax To 1 Step -1
If Sheet4.Cells(Rw, 1).Value = "" Then 'Ａ列が空白だった場合

Sheet4.Rows(Rw).Delete '行削除

ElseIf Sheet4.Cells(Rw, 1).Value = "日付" Then 'A列が日付だった場合

Sheet4.Rows(Rw).Delete '行削除

End If
Next Rw
Application.ScreenUpdating = True

'B行を削除
Sheet4.Range("B:B").Delete

End Sub


−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−

ここまでで、IEを起動して結果をシート4に書き出すイメージで。
以下、シート4に書き出された結果に対して、色をつけるイメージです。

−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myColor As Variant
Dim clrNo As Integer

clrNo = 6
'
' For clrNo = 1 To 6
If Target.Count <> 1 Then Exit Sub
If Target.Column <> clrNo Then Exit Sub

Application.EnableEvents = False
Select Case Target.Value
Case "持戻（ご不在）"
myColor = 3 '赤
Case "配達完了"
myColor = 8 '水色
Case "調査中"
myColor = 6 '黄
Case "住所確認"
myColor = 6 '黄
Case "伝票番号未登録"
myColor = 15 'グレー
Case "伝票番号誤り"
myColor = 15 'グレー
Case "保管中"
myColor = 4 'ライトグリーン
Case "荷物受付"
myColor = 4 'ライトグリーン
Case "配達日・時間帯指定（保管中）"
myColor = 4 'ライトグリーン
Case "配達予定"
myColor = 4 'ライトグリーン
' Case "発送"
' myColor = 13 '紫
' Case "配達中"
' myColor = 13 '紫
Case "作業店通過"
myColor = 13 '紫
Case Else
myColor = xlNone
End Select
Cells(Target.Row, 1).Resize(1, clrNo).Interior.ColorIndex = myColor
Application.EnableEvents = True
'
' Next clrNo
End Sub


−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−

以上。
なんか、いろいろ適当に作ってますので、プログラム上エラーがあるとは思います。
とりあえずウチのとこでは動いてるので、苦情は受け付けられませんし、回答もできません。
すいません。

ちなみに環境的には
windows xp
excel2003
IE8
です。

なにかの役に立てば良いです。

以下追記
どうやらＡ1列に何も入力されていないとエラーになるみたい。
エクセルを立ち上げなおせば問題ないみたいなので特に修正しません。
もともと、個人的な事情で造ったいい加減なプログラムなので。