（VBAマクロ）複数月に渡る過去の天気の取得方法

質問

現在、各サイトを参考にしながら、下記のコードで一ヶ月分は取得できていますが、複数月を取得する場合、どのようにすればいいでしょうか。
　たとえば2014年12月1日～2015年1月17日の期間
Excel2013を使用していますが、外部データの取り込みではエラーが出るため、使用していません。

Sub Main()
Application.ScreenUpdating = False '画面更新禁止

Dim objIE As Object
Set objIE = CreateObject("InternetExplorer.Application")
'IEを開いて非表示
objIE.Visible = False
yy = Range("a1").Value
mo = Range("B1").Value
da = Range("C1").Value
'指定URLへ移動する
objIE.Navigate "http://www.data.jma.go.jp/obd/stats/etrn/view/daily_s1.php?prec_no=74&block_no=47893&year=" & yy & "&month=" & mo & "&day=" & da & "&view="

'表示完了を待つ .readyState と .Busy を見る
While objIE.readyState <> 4 Or objIE.Busy = True 'IEがBusyの間 待つ
DoEvents
Wend
DoEvents
'表示待ちここまで

'Tableタグを抜き出す
Dim objT As Object 'テーブルオブジェクトの格納用
Set objT = objIE.document.all("tablefix1") '.all("id名前")でテーブルタグを抜く

If objT Is Nothing Then '↑上で見つかったか？
MsgBox "err 表が見つかりません、 IDを確認してください。"
Exit Sub 'エラーなので抜ける。
End If

Dim x As Integer '列の管理
Dim y As Integer '行の管理
'Worksheets(3).Select
'Webの表をシートへ転記(代入する)
For y = 0 To objT.Rows.Length - 1 '行のループ
For x = 0 To objT.Rows(y).Cells.Length - 1 '列数分ループ
Worksheets(3).Cells(y + 2, x + 1) = objT.Rows(y).Cells(x).innertext
'↑y+1 1行目から書き出す、11行目にするには y+1+10に変更する
Next
Next

'objIE.ExecWB 17, 0 'OLECMDID_SELECTALL = 17 全てを選択
'objIE.ExecWB 12, 0 'OLECMDID_COPY = 12 コピー
'Range("A1").Select
'ActiveSheet.PasteSpecial Format:="HTML" 'HTML形式で貼り付ける

objIE.Quit '.QuitでIEを閉じる

'使用したオブジェクト変数を空に。
Set objT = Nothing
Set objIE = Nothing
Worksheets(2).Select
Application.ScreenUpdating = True '画面更新
End Sub

回答No.3

WindFaller

こんばんは。

#2の回答者です。
>問題がでたら確認していきたい

まだ、ありますね。
objIE.document.all("tablefix1")　だからでしょうか？
文字が抜けてしまっていませんか？やり方は、ある程度決めているものの、まだ、実行には移していません。必要とされるデータがどの程度かにもよります。どうしましょうか？

今回は、手直ししただけですが、本来、一度、HTMLのコード全体見て、詳しく検証しないといけないかもしれません。

あっ、それから、私は、このデータの質問は、今回で、VBAで取得するコードは3度めなのですが、少しずつ、サイトの中身が変わっているようで、以前のものは使えませんでした。つまり、この先も、また使えなくなりそうな気がするということです。

お礼

重ねてのご返答ありがとうございます。

補足

ご連絡が遅くなり申し分けありません。
現在、サイトへ接続ができないらしく、確認ができませんが、最後の方を下記のようにすることで先日まで全ての項目が取得できていました。　数値だけでなく、文字も取得できていました。
For y = 0 To objT.Rows.Length - 1 '行のループ
For x = 0 To objT.Rows(y).Cells.Length - 1 '列数分ループ
h = a + y + 2
If h >= a + 6 Then
ws.Cells(h, x + 1) = objT.Rows(y).Cells(x).innertext
'↑y+1 1行目から書き出す、11行目にするには y+1+10に変更する
End If
Next
Next
a = a + y '連続

そもそも、外部データの取り込みでエラーが出なければいいのですが・・・。

回答No.2

WindFaller

こんばんは。

このご質問は、以前にもここで出ていた覚えがあります。
少し、手直ししてみましたが、テーブルの部分で値が取得できていない部分があるようですから、手直しするべき部分がありそうです。

FirstDay = .Range("C1").Value　'始めの日
EndDay = .Range("D1").Value 　'終わりの日
ですが、これは、現在のコードは月単位の取得しかありませんから、日付を指定しても、意味ありませんね。（^^;

'//
Dim a As Long　'モジュール変数
Sub Main()
　Dim FirstDay As Variant
　Dim EndDay As Variant
　Dim mTitle As Variant
　Dim n As Integer, i As Long, j As Long
　Dim yy As Long, mo As Long, da As Long
　Dim mDate As Date
　Dim ws As Worksheet
　Dim wsCount As Integer
　n = 3 '開始Sheet番号
　a = 0 '初期化
　'IEを開いて非表示
　Set ws = Worksheets(n)
　With ws
　　.UsedRange.Offset(1).ClearFormats '画面の初期化
　　FirstDay = .Range("C1").Value 'yy/mm/dd
　　EndDay = .Range("D1").Value 'yy/mm/dd
　　j = DateDiff("m", FirstDay, EndDay)
　　.Range("A3").Resize(1, 21).Value = Split(",,,,,,,,,,,,,,,,,雪,,天気概況,", ",")
　　.Range("A4").Resize(1, 21).Value = Split(",気圧,,降水量,,,気温(℃),,,湿度(%),,,最大風速,,最大瞬間風速,,日照時間,降雪,最深積雪,昼,夜,", ",")
　　.Range("A5").Resize(1, 21).Value = Split("日,現地（平均),海面（平均),合計,1時間,10分間,平均,最高,最低,平均,最小,平均風速,風速,風向,風速,風向,,合計,値,(06:00-18:00),(18:00-翌日06:00)", ",")
　If j <= 0 Then Exit Sub
　　yy = Year(FirstDay)
　　mo = Month(FirstDay)
　　da = Day(FirstDay)
　For i = 0 To j
　　mDate = DateSerial(yy, mo + i, da)
　　yy = Year(mDate)
　　mo = Month(mDate)
　　da = Day(mDate)
　　.Cells(3 + a + i, 1).Value = yy & "年" & mo & "月"
　　Call sGetData(yy, mo, da, ws)
　Next i
　End With
End Sub
Sub sGetData(yy As Long, mo As Long, da As Long, ws As Worksheet)
　　Dim x As Long　'列の管理
　　Dim y As Long　'行の管理

　　Dim objIE As Object
　　 Set objIE = CreateObject("InternetExplorer.Application")
　　 objIE.Visible = False
　　 Application.ScreenUpdating = False '画面更新禁止
　　'指定URLへ移動する
　　objIE.Navigate " http://www.data.jma.go.jp/obd/stats/etrn/view/daily_s1.php?prec_no=74&block_no=47893&year=" & yy & "&month=" & mo & "&day=" & da & "&view="
　　'Debug.Print "http://www.data.jma.go.jp/obd/stats/etrn/view/daily_s1.php?prec_no=74&block_no=47893&year=" & yy & "&month=" & mo & "&day=" & da & "&view="
　　'表示完了を待つ .readyState と .Busy を見る
　　While objIE.readyState <> 4 Or objIE.Busy = True 'IEがBusyの間 待つ
　　　　DoEvents
　　Wend
　　DoEvents
　　'表示待ちここまで
　　　　'Tableタグを抜き出す
　　Dim objT As Object 'テーブルオブジェクトの格納用
　　Set objT = objIE.document.All("tablefix1")　'.all("id名前")でテーブルタグを抜く
　　If objT Is Nothing Then　'↑上で見つかったか？
　　　　MsgBox "err 表が見つかりません、 IDを確認してください。"
　　　　End　'エラーなので抜ける。 '**変更
　　End If
　　For y = 0 To objT.Rows.Length - 1　'行のループ
　　　　For x = 0 To objT.Rows(y).Cells.Length - 1　'列数分ループ
　　　　　　If IsNumeric(objT.Rows(y).Cells(x).innertext) Then
　　　　　　ws.Cells(a + y + 2, x + 1) = objT.Rows(y).Cells(x).innertext
　　　　　　'↑y+1 1行目から書き出す、11行目にするには y+1+10に変更する
　　　　　　End If
　　　　Next
　　Next
　　a = a + y + 2 - 4 '連続
　 'objIE.ExecWB 17, 0　'OLECMDID_SELECTALL = 17 全てを選択
　　'objIE.ExecWB 12, 0　'OLECMDID_COPY = 12 コピー
　　'Range("A1").Select
　　'ActiveSheet.PasteSpecial Format:="HTML" 'HTML形式で貼り付ける
　　　　objIE.Quit　'.QuitでIEを閉じる
　　'使用したオブジェクト変数を空に。
　　Set objT = Nothing
　　Set objIE = Nothing '一旦オブジェクトを開放しないといけない模様
　　Application.ScreenUpdating = True '画面更新
End Sub
'//

お礼

お礼が遅くなり申し訳ありません。
問題点などご指摘頂きありがとうございます。また、各項目も対応するようにして頂き、非常に見やすくなりました。
やりたいことが出来ており、現状きれいに動いているようですが、問題がでたら確認していきたいと思います。
ありがとうございました。

補足

上の補足に書けばよかったのですが、回答後に気がついたため、こちらで失礼します。
複数月にまたがる場合、月数の取得がおかしくなっていました。
12～2月を取得したいのに、12,１,3となっていました。
　24　For i = 0 To j　'変更後
　　yy = Year(FirstDay)
　　mo = Month(FirstDay)
　　da = Day(FirstDay)
　28　'For i = 0 To j　以前の位置
ループ位置の変更で対応できました。
サイトの構成が変わってしまうことがあるんですね。肝に銘じておきます。

回答No.1

weboner

HPの作りが1ヶ月単位でしか表示できないようになっているので、翌月を指定して再度取り込みを実施するしかないですね

お礼

ご回答ありがとうございます。
２ヶ月、３ヶ月を別のセルで指定して指定月まで繰り返すような形にしたいという思いがあったのですが、言葉足らずで説明不足でした。
貴重なお時間をありがとうございました。