EXCEL VBAで気象庁ホームページから風向風速,降水量,気温,日照時間のデータをダウンロードする
2011年9月19日の記事に,日照時間をダウンロードするコードを追加しました.更にデータに付加される記号について判別する仕様としました.
http://www.data.jma.go.jp/obd/stats/data/mdrr/man/remark.html
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 mySunAr(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 k As Long
Dim m As Long
Dim n As Long
Dim myPlace As StringApplication.ScreenUpdating = False
j = 0
k = 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, 5) = "" _
Or Right(myRng(i + 4, 5), 2) = " ]" _
Or myRng(i + 4, 5) = "−" _
Or myRng(i + 4, 5) = "×" _
Or myRng(i + 4, 4) = "///" _
Or myRng(i + 4, 4) = "#" _
Or myRng(i + 4, 4) = "" _
Or Right(myRng(i + 4, 4), 2) = " ]" _
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) = "#" _
Or myRng(i + 4, 2) = "" _
Or Right(myRng(i + 4, 2), 2) = " ]" _
Or 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) = "#" _
Or myRng(i + 4, 3) = "" _
Or Right(myRng(i + 4, 3), 2) = " ]" _
Or 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
For i = 1 To 144
Select Case True
Case myRng(i + 4, 8) = "///" _
Or myRng(i + 4, 8) = "#" _
Or myRng(i + 4, 8) = "" _
Or Right(myRng(i + 4, 8), 2) = " ]" _
Or myRng(i + 4, 8) = "−" _
Or myRng(i + 4, 8) = "×"
k = k - 1
Case Right(myRng(i + 4, 8), 2) = " )"
mySunAr(k, 0) = myPlace
mySunAr(k, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
mySunAr(k, 2) = myRng(i + 4, 8)
Case Else
mySunAr(k, 0) = myPlace
mySunAr(k, 1) = DateSerial(myYear, myMonth, myDay) + myRng.Cells(i + 4, 1) - myRng.Cells(5, 1)
mySunAr(k, 2) = myRng(i + 4, 8)
End Select
k = k + 1
If k > 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
Set mySht = Worksheets.Add
With mySht
.Name = myYear & "年日照時間"
.Range("$A$1") = "Point"
.Range("$B$1") = "Date_Time"
.Range("$C$1") = "Sunshine"
.Range("$A$2:$C$52705") = mySunAr
End With
Debug.Print myYear & " " & Timer - myTime
Set myRng = Nothing
Set mySht = Nothing
Application.ScreenUpdating = True
End Sub