EXCEL VBAで気象庁ホームページから風向風速,降水量,気温,日照時間のデータをダウンロードする

2011年9月19日の記事に,日照時間をダウンロードするコードを追加しました.更にデータに付加される記号について判別する仕様としました.

http://www.data.jma.go.jp/obd/stats/data/mdrr/man/remark.html


Option Explicit

Sub 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 String

Application.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