気象庁のホームページから風向風速，降水量，気温のデータをダウンロードする
2011年9月6日の記事では，気象庁のホームページから風向と風速をダウンロードするコードを紹介しました．今回は同様に，指定した年の前月までの降水量と気温の10分ごとのデータをダウンロードするコードを紹介します．
Option ExplicitSub WEBQUERY()
Dim mySht As Worksheet
Dim myAnswer As Variant
Dim myWindAr(52703, 3) As Variant
Dim myRainAr(52703, 2) As Variant
Dim myKionAr(52703, 2) 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 m As Long
Dim n As Long
Dim myPlace As StringApplication.ScreenUpdating = False
j = 0
m = 0
n = 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) = " )"
myWindAr(j, 0) = myPlace
myWindAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myWindAr(j, 2) = Replace(myRng(i + 4, 5), " )", "")
myWindAr(j, 3) = Replace(myRng(i + 4, 4), " )", "")
Case Right(myRng(i + 4, 5), 2) = " )"
myWindAr(j, 0) = myPlace
myWindAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myWindAr(j, 2) = Replace(myRng(i + 4, 5), " )", "")
myWindAr(j, 3) = myRng(i + 4, 4)
Case Right(myRng(i + 4, 4), 2) = " )"
myWindAr(j, 0) = myPlace
myWindAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myWindAr(j, 2) = myRng(i + 4, 5)
myWindAr(j, 3) = Replace(myRng(i + 4, 4), " )", "")
Case Else
myWindAr(j, 0) = myPlace
myWindAr(j, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myWindAr(j, 2) = myRng(i + 4, 5)
myWindAr(j, 3) = myRng(i + 4, 4)
End Select
j = j + 1
If j > 52703 Then Exit For
Next i
For i = 1 To 144
Select Case True
Case myRng(i + 4, 2) = "///" Or myRng(i + 4, 2) = "#"
m = m - 1
Case Right(myRng(i + 4, 2), 2) = " )"
myRainAr(m, 0) = myPlace
myRainAr(m, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myRainAr(m, 2) = myRng(i + 4, 2)
Case Else
myRainAr(m, 0) = myPlace
myRainAr(m, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myRainAr(m, 2) = myRng(i + 4, 2)
End Select
m = m + 1
If m > 52703 Then Exit For
Next i
For i = 1 To 144
Select Case True
Case myRng(i + 4, 3) = "///" Or myRng(i + 4, 3) = "#"
n = n - 1
Case Right(myRng(i + 4, 2), 3) = " )"
myKionAr(n, 0) = myPlace
myKionAr(n, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myKionAr(n, 2) = myRng(i + 4, 3)
Case Else
myKionAr(n, 0) = myPlace
myKionAr(n, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
myKionAr(n, 2) = myRng(i + 4, 3)
End Select
n = n + 1
If n > 52703 Then Exit For
Next i
Application.DisplayAlerts = False
mySht.Delete
Application.DisplayAlerts = True
Next myDay
Next myMonth
Set mySht = Worksheets.Add
With mySht
.Name = myYear & "年風向風速"
.Range("$A$1") = "Point"
.Range("$B$1") = "Date_Time"
.Range("$C$1") = "Direction"
.Range("$D$1") = "Average_Speed"
.Range("$A$2:$D$52705") = myWindAr
End With
Set mySht = Worksheets.Add
With mySht
.Name = myYear & "年降水量"
.Range("$A$1") = "Point"
.Range("$B$1") = "Date_Time"
.Range("$C$1") = "Precipitation"
.Range("$A$2:$C$52705") = myRainAr
End With
Set mySht = Worksheets.Add
With mySht
.Name = myYear & "年気温"
.Range("$A$1") = "Point"
.Range("$B$1") = "Date_Time"
.Range("$C$1") = "Temperature"
.Range("$A$2:$C$52705") = myKionAr
End With
Debug.Print Timer - myTime
Set myRng = Nothing
Set mySht = Nothing
Application.ScreenUpdating = True
End Sub
