Web Query | Improve Society

　森林を構成する樹木の分布と積算温度には対応が見られます．暖かい地方では冬の寒さが，寒い地方では夏の暑さが植物の分布を制約するためです．吉良竜夫はこの点に注目し，暖かさの指数warmth indexおよび寒さの指数coldness indexという温量指数を考案しました．

　暖かさの指数とは『月平均気温が５℃を越す月の平均気温から５℃を引いた値の合計』です．寒さの指数とは『月平均気温が５℃未満の月について，月の平均気温と５℃との差の合計』でマイナスをつけて表現します．温量指数と言う場合，普通は暖かさの指数を指します．

　日本の植生帯を特徴づける樹木の分布帯と暖かさの指数との関係をみると，180, 85, 45, 15のところにそれぞれの植生帯の上端（すなわち低温側の分布限界）が集中していると言われます．それに基づいて日本の気候は次のように分類されます．

亜熱帯240から180
暖温帯（丘陵帯）180から85
冷温帯（山地帯）85から45
亜寒帯（亜高山帯）45から15
高山帯15未満

植生類型及び動物の分布を規定する要因

　気象庁のサイトでは日本全国の過去の気象データを蓄積しており，それらをダウンロードすることができます．今回は EXCEL VBA を用いて Web Query によりデータをダウンロードし，温量指数を計算する方法を述べます．

　方法はこちらのページ（EXCEL VBAで気象庁ホームページから風向風速，降水量，気温，日照時間のデータをダウンロードする）に詳しいですが，同ページのコードが動かなかったため，再度マクロの記録から接続文字列などを検証しました．

　まずは手動でダウンロードする場合です．気象庁の過去の気象データ検索ページを開きます．地点，年月日，データの種類で絞り込みます．任意の地点を選択します．ここで必要なのは月平均気温ですので，年月日は年を指定し，月と日は指定せずにおきます．データの種類は『****年の月ごとの値を表示』です．

　ここでブラウザのURLを取得します．

https://www.data.jma.go.jp/obd/stats/etrn/view/monthly_a1.php?prec_no=55&block_no=0552&year=1977&month=&day=&view=p1

　year= で年を指定しており，ここを変数化してループすればEXCELでデータを自動抽出できます．以下コードです．

Option Explicit

Sub WarmthIndex()

Dim mySht               As Worksheet
Dim myWeather(1048574, 15)  As Variant
Dim myURL               As String
Dim myYear              As Integer
Dim myMonth             As Integer
Dim myDate              As Date
Dim myRng               As Range
Dim myPlace             As String
Dim i                   As Integer
Dim j                   As Long
Dim myTime              As Single

    Application.ScreenUpdating = False
    j = 0
    myDate = Date
    myPlace = "**"
    myTime = Timer
    
    For myYear = 1977 To Year(myDate) - 1
        
        myURL = "URL;https://www.data.jma.go.jp/obd/stats/etrn/view/monthly_a1.php?prec_no=55&block_no=0552&year=" & myYear & "&month=&day=&view=p1"
        Set mySht = Worksheets.Add
        Set myRng = mySht.Range("$A$1")
        
        With mySht.QueryTables.Add(Connection:=myURL, Destination:=myRng)
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = """tablefix1"""
            .Refresh BackgroundQuery:=False
        End With
        
        Set myRng = myRng.CurrentRegion
        With myRng
            .Replace What:=" ", Replacement:=""
            .Replace What:="]", Replacement:=""
            .Replace What:=")", Replacement:=""
            .Replace What:="/", Replacement:=""
        End With
        
        For i = 0 To myRng.Rows.Count - 4
            myWeather(j, 0) = myPlace
            myWeather(j, 1) = myYear
            myWeather(j, 2) = myRng(i + 4, 1)
            myWeather(j, 3) = myRng(i + 4, 2)
            myWeather(j, 4) = myRng(i + 4, 3)
            myWeather(j, 5) = myRng(i + 4, 4)
            myWeather(j, 6) = myRng(i + 4, 6)
            myWeather(j, 7) = myRng(i + 4, 7)
            myWeather(j, 8) = myRng(i + 4, 8)
            myWeather(j, 9) = myRng(i + 4, 9)
            myWeather(j, 10) = myRng(i + 4, 10)
            myWeather(j, 11) = myRng(i + 4, 11)
            myWeather(j, 12) = myRng(i + 4, 12)
            myWeather(j, 13) = myRng(i + 4, 13)
            myWeather(j, 14) = myRng(i + 4, 16)
            Select Case True
            Case myRng(i + 4, 6) - 5 <= 0
                myWeather(j, 15) = 0
            Case Else
                myWeather(j, 15) = myRng(i + 4, 6) - 5
            End Select
            j = j + 1
        Next i
        
        Application.DisplayAlerts = False
        mySht.Delete
        Application.DisplayAlerts = True
        
    Next myYear
    
    Set mySht = Worksheets.Add
    With mySht
        .Name = myYear & myPlace & "温量指数"
        .Range("$A$1") = "地点"
        .Range("$B$1") = "年"
        .Range("$C$1") = "月"
        .Range("$D$1") = "降水量合計"
        .Range("$E$1") = "日最大降水量"
        .Range("$F$1") = "1時間最大降水量"
        .Range("$G$1") = "日平均気温"
        .Range("$H$1") = "日最高気温"
        .Range("$I$1") = "日最低気温"
        .Range("$J$1") = "最高気温"
        .Range("$K$1") = "最低気温"
        .Range("$L$1") = "平均風速"
        .Range("$M$1") = "最大風速"
        .Range("$N$1") = "最大風向"
        .Range("$O$1") = "日照時間"
        .Range("$P$1") = "温量指数"
        .Range("$A$2:$P$1048576") = myWeather
    End With
    
    Debug.Print Round(Timer - myTime, 2)
    Set myRng = Nothing
    Set mySht = Nothing
    Application.ScreenUpdating = True
    
End Sub

　ピボットテーブルを挿入します．設定はデフォルトで結構です．『行』には年をドラッグします．『値』には温量指数をドラッグします．『集計方法』はデータの合計です．これで温量指数が算出されます．

　グラフを追加するなら折れ線グラフが良いでしょう．下図は当地の温量指数の推移ですが，1987年までは95から105の範囲を推移していたのが，1988年から2004年までは95から115までの範囲を乱高下を繰り返し，2005年以降は110近辺の範囲に収まってきているように見えます．全体として温暖化傾向が見られます．

　次に，夏枯れ指数を算出します．夏枯れ指数とは『日最高気温が25℃を超えた日について25℃との差を年間で合計した値』（武井和久）のことです．基準とした25℃は寒地型芝草が弱り始める温度です．コードのみ載せます．

Option Explicit

Sub SummerSlumpIndex()

Dim mySht               As Worksheet
Dim myWeather(1048574, 13)  As Variant
Dim myURL               As String
Dim myYear              As Integer
Dim myMonth             As Integer
Dim myDate              As Date
Dim myRng               As Range
Dim myPlace             As String
Dim i                   As Integer
Dim j                   As Long
Dim myTime              As Single

    Application.ScreenUpdating = False
    j = 0
    myDate = Date
    myPlace = "**"
    myTime = Timer
    
    For myYear = 1977 To Year(myDate) - 1
        
        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 myMonth = 1 To 12
            
            myURL = "URL;https://www.data.jma.go.jp/obd/stats/etrn/view/daily_a1.php?prec_no=55&block_no=0552&year=" & myYear & "&month=" & myMonth & "&day=&view=p1"
            Set mySht = Worksheets.Add
            Set myRng = mySht.Range("$A$1")
    
            With mySht.QueryTables.Add(Connection:=myURL, Destination:=myRng)
                .WebSelectionType = xlSpecifiedTables
                .WebFormatting = xlWebFormattingNone
                .WebTables = """tablefix1"""
                .Refresh BackgroundQuery:=False
            End With
            
            Set myRng = myRng.CurrentRegion
            With myRng
                .Replace What:=" ", Replacement:=""
                .Replace What:="]", Replacement:=""
                .Replace What:=")", Replacement:=""
                .Replace What:="/", Replacement:=""
            End With
            
            For i = 0 To myRng.Rows.Count - 4
                myWeather(j, 0) = myPlace
                myWeather(j, 1) = DateSerial(myYear, myMonth, myRng(i + 4, 1))
                myWeather(j, 2) = myRng(i + 4, 2)
                myWeather(j, 3) = myRng(i + 4, 3)
                myWeather(j, 4) = myRng(i + 4, 5)
                myWeather(j, 5) = myRng(i + 4, 6)
                myWeather(j, 6) = myRng(i + 4, 7)
                myWeather(j, 7) = myRng(i + 4, 8)
                myWeather(j, 8) = myRng(i + 4, 9)
                myWeather(j, 9) = myRng(i + 4, 10)
                myWeather(j, 10) = myRng(i + 4, 13)
                myWeather(j, 11) = myRng(i + 4, 14)
                Select Case True
                Case myRng(i + 4, 5) - 5 <= 0
                    myWeather(j, 12) = 0
                Case Else
                    myWeather(j, 12) = myRng(i + 4, 5) - 5
                End Select
                Select Case True
                Case myRng(i + 4, 6) - 25 <= 0
                    myWeather(j, 13) = 0
                Case Else
                    myWeather(j, 13) = myRng(i + 4, 6) - 25
                End Select
                j = j + 1
            Next i
                        
            Application.DisplayAlerts = False
            mySht.Delete
            Application.DisplayAlerts = True
            
        Next myMonth
    Next myYear
    
    Set mySht = Worksheets.Add
    With mySht
        .Name = myYear & myPlace
        .Range("$A$1") = "地点"
        .Range("$B$1") = "年月日"
        .Range("$C$1") = "降水量合計"
        .Range("$D$1") = "1時間最大降水量"
        .Range("$E$1") = "平均気温"
        .Range("$F$1") = "最高気温"
        .Range("$G$1") = "最低気温"
        .Range("$H$1") = "平均風速"
        .Range("$I$1") = "最大風速"
        .Range("$J$1") = "最大風向"
        .Range("$K$1") = "最多風向"
        .Range("$L$1") = "日照時間"
        .Range("$M$1") = "温量指数"
        .Range("$N$1") = "夏枯れ指数"
        .Range("$A$2:$N$1048576") = myWeather
    End With
    
    Debug.Print Round(Timer - myTime, 2)
    Set myRng = Nothing
    Set mySht = Nothing
    Application.ScreenUpdating = True
    
End Sub

　ピボットテーブルを挿入します．『行』には年月日をドラッグします．『値』には夏枯れ指数をドラッグします．『集計方法』はデータの合計です．更に『分析』タブの『グループの選択』コマンドをクリックし，『グループ化』ウィンドウで『年』のみを選択して年月日を集約します．これで夏枯れ指数が算出されます．同様に温暖化傾向が見られます．

タグ: Web Query

EXCEL VBAのWeb Queryを用いて気象庁の過去のデータをダウンロードし温量指数および夏枯れ指数を求めるには

2024年4月
月	火	水	木	金	土	日
1	2	3	4	5	6	7
8	9	10	11	12	13	14
15	16	17	18	19	20	21
22	23	24	25	26	27	28
29	30