気象庁のホームページから気象データをダウンロードする

2011年8月13日の記事では簡易風配図の作成方法を述べました．今回は気象庁のホームページから特定観測地点の10分ごとの風向と平均風速をダウンロードする方法を述べます．

EXCEL 2010のWebクエリを使用します．

手動で覗いてみたところ，1時間おきのデータは1976年2月29日以降のみです．10分おきのデータは1994年4月1日以降のみです．機器の故障か不明ですが一部データの欠損があり，"///"，"#"というテキストで表現されています．



Option Explicit
Sub WEBQUERY()
Dim mySht   As Worksheet

Dim myAnswer    As Variant

Dim myAr(52703, 3)   As Variant

Dim myURL   As String

Dim myYear  As Integer

Dim myMonth As Integer

Dim myDay   As Integer

Dim myDate  As Date

Dim tmpDate As Date

Dim myTime  As Single

Dim myRng   As Range

Dim i       As Integer

Dim j       As Long

Dim myPlace As String
    Application.ScreenUpdating = False

    j = 0

    myDate = Date

    

    myAnswer = Application.InputBox(Prompt:="1994から今年の間の西暦年を4桁で入力してください", Default:=Year(myDate), Type:=1)

    If TypeName(myAnswer) = "Boolean" Then Exit Sub

    If myAnswer < 1994 Or myAnswer > Year(myDate) Then Exit Sub

    myYear = myAnswer

    

    myTime = Timer

    

    For myMonth = 1 To 12

        

        On Error Resume Next

        If DateSerial(myYear, myMonth, 1) - DateSerial(Year(myDate), Month(myDate), 1) >= 0 Then

            Exit For

        End If

        On Error GoTo 0

        

        For myDay = 1 To 31

            

            On Error Resume Next

            tmpDate = DateValue(myYear & "/" & myMonth & "/" & myDay)

            If Err.Number <> 0 Then

                Exit For

            End If

            On Error GoTo 0

            

            myURL = "URL;http://www.data.jma.go.jp/obd/stats/etrn/view/10min_a1.php?prec_no=55&prec_ch=%95x%8ER%8C%A7&block_no=0552&block_ch=%93v%94g&year=" & myYear & "&month=" & myMonth & "&day=" & myDay

            Set mySht = Worksheets.Add

            Set myRng = mySht.Range("$A$1")

    

            With mySht.QueryTables.Add(Connection:=myURL, Destination:=myRng)

                .WebSelectionType = xlSpecifiedTables

                .WebFormatting = xlWebFormattingNone

                .WebTables = "3"

                .Refresh BackgroundQuery:=False

            End With

            

            myPlace = Application.WorksheetFunction.Replace(mySht.Range("$A$1"), Application.WorksheetFunction.Find(" ", mySht.Range("$A$1")), Len(mySht.Range("$A$1")), "")

            

            For i = 1 To 144

                

                Select Case True

                Case myRng(i + 4, 5) = "///" Or myRng(i + 4, 5) = "#" Or myRng(i + 4, 4) = "///" Or myRng(i + 4, 4) = "#"

                    j = j - 1

                Case Right(myRng(i + 4, 5), 2) = " )" And Right(myRng(i + 4, 4), 2) = " )"

                    myAr(j, 0) = myPlace

                    myAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)

                    myAr(j, 2) = Replace(myRng(i + 4, 5), " )", "")

                    myAr(j, 3) = Replace(myRng(i + 4, 4), " )", "")

                Case Right(myRng(i + 4, 5), 2) = " )"

                    myAr(j, 0) = myPlace

                    myAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)

                    myAr(j, 2) = Replace(myRng(i + 4, 5), " )", "")

                    myAr(j, 3) = myRng(i + 4, 4)

                Case Right(myRng(i + 4, 4), 2) = " )"

                    myAr(j, 0) = myPlace

                    myAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)

                    myAr(j, 2) = myRng(i + 4, 5)

                    myAr(j, 3) = Replace(myRng(i + 4, 4), " )", "")

                Case Else

                    myAr(j, 0) = myPlace

                    myAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)

                    myAr(j, 2) = myRng(i + 4, 5)

                    myAr(j, 3) = myRng(i + 4, 4)

                End Select

                

                j = j + 1

                If j > 52703 Then Exit For

                

            Next i

            

            Application.DisplayAlerts = False

            mySht.Delete

            Application.DisplayAlerts = True

            

        Next myDay

    Next myMonth

    

    Set mySht = Worksheets.Add

    mySht.Name = myYear & "年風向風速"

    mySht.Range("$A$1") = "Point"

    mySht.Range("$B$1") = "Date_Time"

    mySht.Range("$C$1") = "Direction"

    mySht.Range("$D$1") = "Average_Speed"

    mySht.Range("$A$2:$D$52705") = myAr

    Debug.Print Timer - myTime

    

    Set myRng = Nothing

    Set mySht = Nothing

    Application.ScreenUpdating = True

    

End Sub

1994年から2011年まで処理した結果，イミディエイトウィンドウには経過時間が以下のように出力されました．かなり時間のかかる処理です．