【Excel VBA】気象庁のデータをスクレイピング
水文・水質・気象
VBA
エクセル
スクレイピング
1．気象データのスクレイピング
自然科学や土木工学，農業農村工学などを勉強している人の中には気象庁の気象データを利用したことがある人も少なくないと思います．
でも，たくさんの気象データをダウンロードするときにこう思ったことはないですか？ 「気象庁のホームページから小分けにデータダウンロードするのめんどいわぁ」と．
多地点・他項目で10分単位の気象データが必要な場合なんかは特にめんどくさいですよね．
そこで気象データのダウンロードを自動で行う(スクレイピング)プログラムを紹介したいと思います． 今回は自然科学系のデータ処理と相性がいいエクセル・VBAを使っていきたいと思います．
注意点
一度に大量のデータをダウンロードすると気象庁のサーバーに過負荷がかかるので，自動ダウンロードとはいえ可能な限り小分けしてダウンロードしたり，他の利用者が少ない時間帯などに利用するといった配慮をよろしくお願いいたします．
VBAについてよく知らないという方はこちらのサイトなどをどうぞ
2．スクレイピング用ファイルおよびプログラム
スクレイピング用エクセルファイルは下記リンクからダウンロード可能です． ご自由にお使いください． 気象庁気象データスクレイピング_20230921.xlsm
３．使い方
気象庁の「過去の気象データ検索」というページでダウンロードしたい観測所を選択すると，URLの「prec_no」と「block_no」に観測所固有の番号が入ります．
気象庁 過去の気象データ検索 https://www.data.jma.go.jp/obd/stats/etrn/index.php
都道府県ナンバー(prec_no)，ブロックナンバー(block_no)，期間を入力してボタンを押せばスクレイピングが始まります．
4．テスト
大阪気象台のデータをダウンロードしてみます．
期間は2018年2月1日〜4月1日，データは1時間単位です．
5．結果
無事，気象データをダウンロードすることができました．
6．おわりに
最後までお付き合い頂き，ありがとうございました．
普段からエクセルでデータ処理などをしている方にとっては便利かと思います． プログラムの使用は自由ですので，研究や自主学習に役立ててください．
なお，気象庁のサーバーに迷惑をかけないよう常識的な範囲での利用をよろしくお願いいたします．
最近知ったんですが，Pythonでも同様のスクレイピングプログラムが出回っているそうです． Pythonの場合は気象庁のページにあるダウンロード開始ボタンをクリックする作業を自動化するというものらしく，本記事のプログラムよりもかなり速いそうです． 筆者はPythonアレルギーで，そこまで高速な作業を必要とする場合もあまりないのでVBAで記述していますが，高速で大量のデータをダウンロードしたい方はPythonのプログラムを試してみるのをお勧めします．
7．計算用プログラム
読まなくてもスクレイピングは可能なので興味のある方のみご覧ください．
Option Explicit
'SD(Start Date)はデータを取得する期間の開始日
'ED(End Date)はデータを取得する期間の終了日
'Cntjは気象データの種数をカウントする
'StepTは1つのエクセルファイルに保存されるデータの年数
'Pathはデータの保存先フォルダ
Dim SD As Date, ED As Date, Cntj As Integer, StepT As Integer, Path As String
Private Sub UserForm_Initialize()
'コンボボックスを初期化(年月日の選択肢を設定)するための関数
Application.ScreenUpdating = False
'コンボボックスの初期化
Dim i As Integer, y As Integer
'年
y = Year(Now)
For i = y To 1900 Step -1
With ComboBox1
.AddItem i
End With
With ComboBox3
.AddItem i
End With
With ComboBox5
.AddItem i
End With
With ComboBox8
.AddItem i
End With
Next i
'月
For i = 1 To 12
With ComboBox2
.AddItem i
End With
With ComboBox4
.AddItem i
End With
With ComboBox6
.AddItem i
End With
With ComboBox9
.AddItem i
End With
Next i
'日
For i = 1 To 31
With ComboBox7
.AddItem i
End With
With ComboBox10
.AddItem i
End With
Next i
'1つのエクセルファイルに保存するデータの年数
ListBox1.AddItem 1
ListBox1.AddItem 2
ListBox1.AddItem 5
ListBox1.AddItem 10
Application.ScreenUpdating = True
End Sub
Function RawDataDelete()
'スクレイピングした生データを削除する関数
Worksheets("生データ").Activate
ActiveWindow.SelectedSheets.Delete
Sheets.Add After:=Worksheets("使い方"), Count:=1
ActiveSheet.Name = "生データ"
Cells(1, 1).Select
End Function
Function ArrangedDataDelete()
'集計データを削除する関数
Worksheets("時間単位").Activate
ActiveWindow.SelectedSheets.Delete
Sheets.Add After:=Worksheets("生データ"), Count:=1
ActiveSheet.Name = "時間単位"
Cells(1, 1).Select
Worksheets("日単位").Activate
ActiveWindow.SelectedSheets.Delete
Sheets.Add After:=Worksheets("時間単位"), Count:=1
ActiveSheet.Name = "日単位"
Cells(1, 1).Select
Worksheets("10分単位").Activate
ActiveWindow.SelectedSheets.Delete
Sheets.Add After:=Worksheets("日単位"), Count:=1
ActiveSheet.Name = "10分単位"
Cells(1, 1).Select
End Function
Sub ScrapingHostProgram(ByVal ArgResolutionIndex As Integer)
'Resolution 0：日単位，1：時間単位，2：10分単位
'変数の定義
Dim ListNo(1 To 6) As Integer '日時情報
Dim i As Integer 'カウンタ
Dim ST As Date, ET As Date 'ST：開始日，ET：終了日
Dim StepT As Integer 'データ保存インターバル
Dim Path As String '保存先のフォルダ
Dim PrecNo(1 To 10) As String
Dim BlockNo(1 To 10) As String
Dim ResolutionIndex As Integer
'変数の初期化
ST = Now '開始時刻を取得
Cntj = 0 '気象データの種数
PrecNo(1) = TextBox1.Value
PrecNo(2) = TextBox2.Value
PrecNo(3) = TextBox3.Value
PrecNo(4) = TextBox4.Value
PrecNo(5) = TextBox5.Value
PrecNo(6) = TextBox6.Value
PrecNo(7) = TextBox7.Value
PrecNo(8) = TextBox8.Value
PrecNo(9) = TextBox9.Value
PrecNo(10) = TextBox10.Value
BlockNo(1) = TextBox11.Value
BlockNo(2) = TextBox12.Value
BlockNo(3) = TextBox13.Value
BlockNo(4) = TextBox14.Value
BlockNo(5) = TextBox15.Value
BlockNo(6) = TextBox16.Value
BlockNo(7) = TextBox17.Value
BlockNo(8) = TextBox18.Value
BlockNo(9) = TextBox19.Value
BlockNo(10) = TextBox20.Value
'データ保存インターバルと保存先のフォルダを取得
ResolutionIndex = ArgResolutionIndex
'分解能に合わせて開始日，終了日の表示形式をフォーマット
Select Case ResolutionIndex
Case 0 '日単位
ListNo(1) = Year(Now) - ComboBox1.ListIndex
ListNo(2) = ComboBox2.ListIndex + 1
ListNo(3) = 1
ListNo(4) = Year(Now) - ComboBox3.ListIndex
ListNo(5) = ComboBox4.ListIndex + 1
ListNo(6) = 1
Case Else '時間単位または10分単位
ListNo(1) = Year(Now) - ComboBox5.ListIndex
ListNo(2) = ComboBox6.ListIndex + 1
ListNo(3) = ComboBox7.ListIndex + 1
ListNo(4) = Year(Now) - ComboBox8.ListIndex
ListNo(5) = ComboBox9.ListIndex + 1
ListNo(6) = ComboBox10.ListIndex + 1
End Select
'開始日，終了日を取得
SD = ListNo(1) & "/" & ListNo(2) & "/" & ListNo(3)
ED = ListNo(4) & "/" & ListNo(5) & "/" & ListNo(6)
'エラーチェック
If ED < SD Then
MsgBox ("開始日＜終了日となるように日付を設定してください")
Exit Sub
End If
'スクレイピング
For i = 1 To 10
If PrecNo(i) <> "" And BlockNo(i) <> "" Then
Call DataScrapint_JMA_MeteorologicalData(ResolutionIndex, PrecNo(i), BlockNo(i))
End If
Next i
MsgBox ("スクレイピングが終了しました")
End Sub
Sub CommandButton1_Click()
'メイン関数(日単位でスクレイピング)
Dim ResolutionIndex As Integer '分解能を表すインデックス
Dim ST As Date, ET As Date '計算開始開始時刻・終了時刻
'変数の初期化
ResolutionIndex = 0
ST = Now
'開始通知
Debug.Print "開始時刻：" & ST
'画面更新の停止
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'入力に問題がなければ，ホストプログラムを呼び出す
If ComboBox1.ListIndex <> -1 And ComboBox2.ListIndex <> -1 And ComboBox3.ListIndex <> -1 _
And ComboBox4.ListIndex <> -1 And ListBox1.Text <> "" And TextBox21.Value <> "" Then
'ホストプログラムの呼び出し
Call ScrapingHostProgram(ResolutionIndex)
Else
MsgBox ("正しく入力してください")
Exit Sub
End If
'終了通知
ET = Now
Debug.Print "スクレイピング終了" & vbCrLf & "開始時刻：" & ST & vbCrLf & "終了時刻：" & ET & vbCrLf & "所要時間：" & Format(ET - ST, "h:mm:ss")
'画面更新と警告の再開
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub CommandButton2_Click()
'メイン関数(時間単位でスクレイピング)
Dim ResolutionIndex As Integer '分解能を表すインデックス
Dim ST As Date, ET As Date '計算開始開始時刻・終了時刻
'変数の初期化
ResolutionIndex = 1
ST = Now
'開始通知
Debug.Print "開始時刻：" & ST
'画面更新の停止
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'入力に問題がなければ，ホストプログラムを呼び出す
If ComboBox5.ListIndex <> -1 And ComboBox6.ListIndex <> -1 And ComboBox7.ListIndex <> -1 _
And ComboBox8.ListIndex <> -1 And ComboBox9.ListIndex <> -1 And ComboBox10.ListIndex <> -1 And ListBox1.Text <> "" And TextBox21.Value <> "" Then
'ホストプログラムの呼び出し
Call ScrapingHostProgram(ResolutionIndex)
Else
MsgBox ("正しく入力してください")
Exit Sub
End If
'終了通知
ET = Now
Debug.Print "スクレイピング終了" & vbCrLf & "開始時刻：" & ST & vbCrLf & "終了時刻：" & ET & vbCrLf & "所要時間：" & Format(ET - ST, "h:mm:ss")
'画面更新と警告の再開
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub CommandButton3_Click()
'メイン関数(時間単位でスクレイピング)
Dim ResolutionIndex As Integer '分解能を表すインデックス
Dim ST As Date, ET As Date '計算開始開始時刻・終了時刻
'変数の初期化
ResolutionIndex = 2
ST = Now
'開始通知
Debug.Print "開始時刻：" & ST
'画面更新の停止
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'入力に問題がなければ，ホストプログラムを呼び出す
If ComboBox5.ListIndex <> -1 And ComboBox6.ListIndex <> -1 And ComboBox7.ListIndex <> -1 _
And ComboBox8.ListIndex <> -1 And ComboBox9.ListIndex <> -1 And ComboBox10.ListIndex <> -1 And ListBox1.Text <> "" And TextBox21.Value <> "" Then
'ホストプログラムの呼び出し
Call ScrapingHostProgram(ResolutionIndex)
Else
MsgBox ("正しく入力してください")
Exit Sub
End If
'終了通知
ET = Now
Debug.Print "スクレイピング終了" & vbCrLf & "開始時刻：" & ST & vbCrLf & "終了時刻：" & ET & vbCrLf & "所要時間：" & Format(ET - ST, "h:mm:ss")
'画面更新と警告の再開
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function DataScrapint_JMA_MeteorologicalData(ByVal ArgResolutionIndex As Integer, ByVal PrecNo As String, ByVal BlockNo As String)
'気象庁の気象データをスクレイピングするための関数
'文字列変数str1,str2の「プリフェクチャーナンバー?(prec_no)」は都道府県固有の番号
'文字列変数str1,str2の「ブロックナンバー(block_no)」は観測局固有の番号
'*********変数の定義*********
'カウント用関数
Dim i As Long, j As Long, k As Long, Cnt As Long, Cnts As Long
Dim d As Date, ret As Variant
'スクレイピング先のURLを処理するための変数
Dim str1 As String, str2 As String
Dim str_a1 As String, str_a2 As String, str_s1 As String, str_s2 As String
'スクレイピングしたデータの開始行
Dim Sdata As Integer
'1つのエクセルファイルに保存されるデータの年数
Dim StepT As Integer
'1つのエクセルファイルに保存されるデータの開始年と終了年
Dim T1 As Date, T2 As Date
'保存するファイルの名前
Dim FileName As String
'分解能を表す変数
Dim ResolutionIndex As Integer
'分解能をインデックスから英語表記に変換
Dim ResTerm As String
'整理したデータを格納するワークシートの名前
Dim SN As String
'スクレイピングした気象データの有無を判別するときに使用するセルの行
Dim R1 As Integer, R2 As Integer
'1ページのデータ単位
Dim inc As String
'スクレイピングしたページの日時ラベル
Dim TimeLabel As Date
'変数の初期化
ResolutionIndex = ArgResolutionIndex
'分解能をインデックスから英語表記に変換
Select Case ResolutionIndex
Case 0 '日単位
ResTerm = "daily"
SN = "日単位"
inc = "m"
TimeLabel = "1"
Case 1 '時間単位
ResTerm = "hourly"
SN = "時間単位"
inc = "d"
TimeLabel = "1"
Case 2 '10分単位
ResTerm = "10min"
SN = "10分単位"
TimeLabel = "0:10:00"
inc = "d"
End Select
'入手した気象データの日付に合わせてURLを加工
'気象官署？と地方観測所？によってURLが異なることに対応するための処理
str_a1 = "URL;http://www.data.jma.go.jp/obd/stats/etrn/view/" & ResTerm & "_a1.php?prec_no=" & PrecNo & "&block_no=" & BlockNo & _
"&year=年&month=月&day=日&view="
str_a2 = ResTerm & "_a1.php?prec_no=" & Str(PrecNo) & "&block_no=" & Str(BlockNo) & "&year=年&month=月&day=日&view="
str_s1 = "URL;http://www.data.jma.go.jp/obd/stats/etrn/view/" & ResTerm & "_s1.php?prec_no=" & PrecNo & "&block_no=" & BlockNo & _
"&year=年&month=月&day=日&view="
str_s2 = ResTerm & "_s1.php?prec_no=" & Str(PrecNo) & "&block_no=" & Str(BlockNo) & "&year=年&month=月&day=日&view="
'初期化
d = SD
T1 = SD
StepT = ListBox1.Text
Path = TextBox21.Value
If StepT <= 2 Then
T2 = DateAdd("yyyy", StepT + 1, T1)
ElseIf StepT = 5 Then
T2 = DateAdd("yyyy", StepT - (Year(T1) Mod StepT) + 1, T1)
ElseIf StepT = 10 Then
T2 = DateAdd("yyyy", 10 - (Year(SD) Mod 10) + 1, T1)
End If
Do
'年月日を取得し，URLを決定
ret = Split(d, "/")
str1 = str_a1
str2 = str_a2
ChangeURL:
If Left(ret(1), 1) = 0 Then
ret(1) = CStr(Replace(ret(1), "0", ""))
End If
If Left(ret(2), 1) = 0 Then
ret(2) = CStr(Replace(ret(2), "0", ""))
End If
str1 = Replace(str1, "年", ret(0))
str1 = Replace(str1, "月", ret(1))
str1 = Replace(str1, "日", ret(2))
str2 = Replace(str2, "年", ret(0))
str2 = Replace(str2, "月", ret(1))
str2 = Replace(str2, "日", ret(2))
'データ取得
Worksheets("生データ").Activate
With ActiveSheet.QueryTables.Add(Connection:=str1, Destination:=Range("$A$1"))
.Name = str2
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'データの開始位置を取得
Sdata = 1
Do Until Worksheets("生データ").Cells(Sdata, 1) = TimeLabel
Sdata = Sdata + 1
'データが見つからなさそうなときはURLを切り替えてもう一度やり直し
If Sdata >= 200 Then
str1 = str_s1
str2 = str_s2
'スクレイピングした生データを削除
Call RawDataDelete
GoTo ChangeURL
End If
Loop
'生データの整理
'整理済みのデータ数を取得
Cnt = 4
Do
If Worksheets(SN).Cells(Cnt, 1) = "" Then
Exit Do
End If
Cnt = Cnt + 1
Loop
'気象データの種数を取得
If d = SD And Cntj = 0 Then
j = 2
Do
Cntj = j
j = j + 1
Loop Until WorksheetFunction.CountA(Worksheets("生データ").Range( _
Worksheets("生データ").Cells(20, j), Worksheets("生データ").Cells(28, j))) = 0 '範囲はテキトー
End If
'データラベルの作成
If d = SD Then
For j = 2 To Cntj
For i = Sdata - 3 To Sdata - 1
Worksheets(SN).Cells(i - (Sdata - 4), j) = Worksheets("生データ").Cells(i, j)
Next i
Next j
End If
'データの整理
i = Sdata
Do
'日付をフォーマット
Select Case ResolutionIndex
Case 0
Worksheets(SN).Cells(Cnt, 1).NumberFormatLocal = "yyyy/m/d"
Worksheets(SN).Cells(Cnt, 1) = Year(d) & "/" & Month(d) & "/" & Worksheets("生データ").Cells(i, 1)
Case 1
Worksheets(SN).Cells(Cnt, 1).NumberFormatLocal = "yyyy/m/d h:mm:ss"
Worksheets(SN).Cells(Cnt, 1) = d & " " & i - 23 & ":00:00"
Case 2
Worksheets(SN).Cells(Cnt, 1).NumberFormatLocal = "yyyy/m/d h:mm:ss"
If Hour(Worksheets("生データ").Cells(i, 1)) = 0 And Minute(Worksheets("生データ").Cells(i, 1)) = 0 Then
Worksheets(SN).Cells(Cnt, 1) = DateAdd("d", 1, d) & " 0:00:00"
Else
Worksheets(SN).Cells(Cnt, 1) = Year(d) & "/" & Month(d) & "/" & Day(d) & " " _
& Hour(Worksheets("生データ").Cells(i, 1)) & ":" & Minute(Worksheets("生データ").Cells(i, 1)) & ":00"
End If
End Select
'データの移し替え
For j = 2 To Cntj
Worksheets(SN).Cells(Cnt, j) = Worksheets("生データ").Cells(i, j)
Next j
Cnt = Cnt + 1
i = i + 1
Loop Until Worksheets("生データ").Cells(i, 1) = "" Or IsNumeric(Worksheets("生データ").Cells(i, 1)) = False
'スクレイピングした生データを削除
Call RawDataDelete
'インクリメント
d = DateAdd(inc, 1, d)
'ファイルを保存
If d = T2 Or d = DateAdd(inc, 1, ED) Then
'ファイル名作成
FileName = Replace(PrecNo & "_" & BlockNo & "_" & Str(T1) & "_" & Str(d) & ".xlsm", " ", "")
FileName = Replace(FileName, "/", "")
'保存
Sheets(SN).Select
Sheets(SN).Copy
ChDir Path
ActiveWorkbook.SaveAs FileName:=Path & FileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Workbooks(FileName).Close Savechanges:=False
Windows(ThisWorkbook.Name).Activate
'シートをリセット
Call ArrangedDataDelete
Worksheets(SN).Activate
Debug.Print FileName; "保存終了", Now()
'更新
T1 = T2
T2 = Format(WorksheetFunction.Min(DateAdd("yyyy", StepT, T1), ED), "yyyy/m/d")
End If
Loop Until d = DateAdd(inc, 1, ED)
Worksheets(SN).Activate
End Function
