【水文水質データベース】【使い方】流量データを自動で簡単にダウンロードしてみよう！【スクレイピング】
水文・水質・気象
スクレイピング
VBA
自動化
マクロ
河川データ
1．水文水質データベースとは？
水文水質データベースとは全国の河川や湖沼の雨量，水位，流量，水質，底質，地下水位，地下水質，積雪深，ダム堰等の管理諸量，海象などの水文水質に関わるデータを無料で公開しているサイトです．このサイトは国土交通省が管理しており，データも国交省所管の観測所などで得られたものです．
データの質は正直言って玉石混交ですが，手っ取り早くデータが手に入るので興味のある水系の概況を把握したり，自主学習に使うにはちょうどいいデータベースとなっています．
筆者の専門分野の大きな括りは農業農村工学になりますが，同じく農業農村工学を専門とする学生の中には水文学やかんがい排水の講義を履修した学生もいるのではないでしょうか？ そういった学生にとって特に有益なのは流量，水質のデータあたりだと思います．
水文学の講義では流域からの流出量(要は河川流量)の推定手法としてタンクモデル，貯留関数法，雨水流法といったモデルを聞いたことがあると思います．これらのモデルを実際に自分で組んで計算するときに河川流量のデータは必須です．
本記事では，その河川流量データを自動で，簡単にダウンロードするためのプログラムを紹介したいと思います． 水文学やかんがい排水を学ぶ学生の自主学習などに役立ててもらえたら幸いです． プログラムの使用方法などに関して不明な点があれば，QiitaもしくはTwitter(@6LxAi9GCOmRigUI)で質問していただければ，補足の説明をさせていただきます．
2．水文水質データベースの使い方
はじめに水文水質データベースから普通にデータをダウンロードする方法を紹介します． 短期間・少地点のデータで事足りる場合などはこれから説明する方法で十分だと思います．
今回は「地図からの検索」という方法を試してみることにします．
「地図からの検索」というボタンを押すと日本地図が出るので，好きな地域を拡大します．
今回は長野県上田市にしました．
流量データが欲しいので，オレンジ色の△で示された生田観測所をクリックします．
リストアップされました．
2行目の水位・流量観測所の方をクリックします．
なんか色々表示されましたね．
とりあえず，高時間分解能な流量のデータが欲しいので，「流量月表検索」をクリックします．
この表↓はデータが手に入る期間を表しています．生田観測所は2002年からデータがあるみたいですね．
とりあえず，左上に任意の年月を入力して，「検索開始」をクリックします．
こちらが流量データになります．
あとはエクセルに貼り付けたりすれば使えます．ただ，この方法だと一か月ごとにダウンロードしないといけないので手間はかかります．
3．【スクレイピング】水文水質データベースのデータをまとめてダウンロード
水文学などでモデルを組むときは最低3年分ぐらいデータがあると嬉しいと言われています．2年分はキャリブレーション(モデルのパラメータの同定)に使い，残りの1年分をバリデーション(モデルがうまくいったか確認する)に使うのが一般的ですね． ということはダウンロードを12か月×3年分=36回やらないといけないことになります． まあ，そんなことめんどくさいので自動化したいと思います．
VBAについてさっぱり知らないという方はこちらのサイトの説明がわかりやすいので，よかったらどうぞ
計算用エクセルファイルは下記URLからダウンロードできます． ご自由にお使いください． 水文水質データベース_スクレイピング_20230910.xlsm
使い方
エクセルファイルを起動，または「入力フォームを再表示」ボタンをクリックすると，ユーザーフォームが画面上に表示されます．観測所記号とダウンロードしたい期間の開始月と最終月を入力すれば自動でダウンロードが開始されます．
ダウンロードしたデータはワークシート「集計データ」に格納されます．
4．おわりに
今回の記事の内容はいかがだったでしょうか？ 本記事が水文学やかんがい排水など勉強を支える一助になれば幸いです．
それでは，また次回の記事でお会いしましょう．
今後も農業農村工学(水文学，かんがい排水，土壌物理，水理学)を中心に記事を執筆していきたいと思います． リクエスト等も受け付けておりますので，ご遠慮なく連絡ください． Twitterアカウント：エビぐんかん@6LxAi9GCOmRigUI メール：nnCreatorCircle@gmail.com
5．プログラム
また，ユーザーフォームのコードは以下の通りです(読まなくても大丈夫です)．
Option Explicit
'SD(Start Date)はデータを取得する期間の開始日
'ED(End Date)はデータを取得する期間の終了日
'Cntjは気象データの種数をカウントする
Dim SD As Date, SD2 As Date, ED As Date, Cntj As Integer, ListNo(1 To 4) As Integer
'処理概要 ：スクレイピングした生データを削除する関数
'引数 ：生データが格納されているワークシート名
'戻り値 ：なし
'備考 ：なし
Function Delete_RawData(ByVal sheet_name As String)
Worksheets(sheet_name).Activate 'ワークシートを選択
Cells.Select 'シート全体を選択
Selection.ClearContents 'ワークシートの中身を削除
End Function
'処理概要 ：ユーザーフォーム初期化(年月日，記号の選択肢を設定)関数
'引数 ：なし
'戻り値 ：なし
'備考 ：なし
Private Sub UserForm_Initialize()
'変数の定義
Dim i As Integer '汎用カウンタ
Dim y As Integer '現在の年
'処理高速化のために画面更新を停止する
Application.ScreenUpdating = False
'年を選択するコンボボックスを用意し，値の範囲を設定する
y = Year(Now)
For i = y To 1900 Step -1
YEAR_BEGIN.AddItem i
YEAR_END.AddItem i
Next i
'月を選択するコンボボックスを用意し，値の範囲を設定する
For i = 1 To 12
MONTH_BEGIN.AddItem i
MONTH_END.AddItem i
Next i
'データタイプを選択するコンボボックスを用意し，値の範囲を設定する
DATA_TYPE.AddItem "流量"
DATA_TYPE.AddItem "水位"
'画面更新を再開する
Application.ScreenUpdating = True
End Sub
'処理概要 ：時間単位の水位データをスクレイピングする
'引数 ：なし
'戻り値 ：なし
'備考 ：ユーザーフォームのボタンを押すと実行される
Sub EXECUTE_BUTTON_Click()
'変数の定義
Dim i As Integer '汎用カウンタ
Dim start_time As Date 'スクレイピング処理の開始時刻
Dim finish_time As Date 'スクレイピング処理の終了時刻
Dim data_info(4) As Integer 'データを取得する期間
Dim begin_date As Date 'データを取得する期間の開始日
Dim end_date As Date 'データを取得する期間の終了日
'処理高速化のために画面更新を停止する
Application.ScreenUpdating = False
'開始時刻を取得
start_time = Now
'ユーザーフォームの値が全て入力された状態で実行ボタンが押されたとき
If YEAR_BEGIN.ListIndex <> -1 And MONTH_BEGIN.ListIndex <> -1 And YEAR_END.ListIndex <> -1 And MONTH_END.ListIndex <> -1 And OBSERVATORY_NUMBER.Value <> "" And DATA_TYPE.ListIndex <> -1 Then
'各コンボボックスに入力された年月日を取得
data_info(0) = Year(Now) - YEAR_BEGIN.ListIndex
data_info(1) = MONTH_BEGIN.ListIndex + 1
data_info(2) = Year(Now) - YEAR_END.ListIndex
data_info(3) = MONTH_END.ListIndex + 1
If DATA_TYPE.ListIndex = 0 Then
data_info(4) = 6
ElseIf DATA_TYPE.ListIndex = 1 Then
data_info(4) = 2
End If
'ユーザーフォームの値に入力漏れがある場合
Else
'画面更新を再開する
Application.ScreenUpdating = True
'警告を出してプログラムを終了させる
MsgBox ("正しく入力してください")
Exit Sub
End If
'開始日・終了日を計算用のフォーマットに変更
begin_date = data_info(0) & "/" & data_info(1) & "/1"
end_date = data_info(2) & "/" & data_info(3) & "/1"
'入力された日付が不正な場合は警告を出してプログラムを終了させる
If ED < SD Then
'画面更新を再開する
Application.ScreenUpdating = True
MsgBox ("開始日＞終了日となるように日付を設定してください")
Exit Sub
End If
'スクレイピング関数の呼び出し
Call DataScraping_Ministry_of_LITT_WaterInformationSystem(data_info, OBSERVATORY_NUMBER.Value)
'グラフ更新
Call GraphUpdate(data_info(4))
'処理完了通知
finish_time = Now
MsgBox ("スクレイピングが終了" & vbCrLf & _
"観測所記号：" & OBSERVATORY_NUMBER.Value & vbCrLf & _
"開始時刻：" & start_time & vbCrLf & _
"終了時刻：" & finish_time & vbCrLf & _
"所要時間：" & Format(finish_time - start_time, "h:mm:ss"))
'画面更新を再開する
Application.ScreenUpdating = True
End Sub
'処理概要：水文水質データベースから時間単位の流量データをスクレイピングするための関数
'引数：data_info（データ取得期間の開始年，開始月，終了年，終了月の4つの要素をもつinteger配列），OBSERVATORY_NUMBER（観測所記号）
'戻り値：なし
'備考 ：文字列変数str1,str2の「プリフェクチャーナンバー?(prec_no)」は都道府県固有の番号，文字列変数str1,str2の「ブロックナンバー(block_no)」は観測局固有の番号
Function DataScraping_Ministry_of_LITT_WaterInformationSystem(ByRef data_info() As Integer, ByVal observatory As String)
'変数の定義
Dim i As Long '汎用カウンタ
Dim j As Long '汎用カウンタ
Dim k As Long '汎用カウンタ
Dim begin_date As Date 'データを取得する期間の開始日
Dim end_date As Date 'データを取得する期間の終了日
Dim d As Date '流量データを取得する月
Dim cnt_output As Long 'スクレイピングしたデータを書き出すときの行番号
Dim cnt_month As Integer 'スクレピングした月数
Dim begin_of_month As Date '当該月の開始日
Dim end_of_month As Date '当該月の最終日
Dim begin_data As Integer 'スクレイピングしたデータの開始行番号
Dim url1 As String 'スクレイピングに使用するURL1つ目
Dim rul2 As String 'スクレイピングに使用するURL2つ目
Dim calc_sheet As String '生データを格納するワークシート
Dim raw_sheet As String '集計したデータを格納するワークシート
'処理高速化のために画面更新を停止する
Application.ScreenUpdating = False
'変数の初期化
raw_sheet = "生データ"
calc_sheet = "集計データ"
d = data_info(2) & "/" & data_info(3) & "/1" '変数を新たに定義するのが面倒なのでdを使いまわし
begin_date = DateSerial(Year(d), Month(d), 1) 'データを取得する期間の開始日
end_date = DateSerial(Year(d), Month(d) + 1, 0) 'データを取得する期間の終了日
d = data_info(0) & "/" & data_info(1) & "/1" '流量データを取得する月を開始月に設定する
cnt_output = 2 '2行目から書き出すようにする
cnt_month = 1
'スクレイピングした生データを削除（念のための初期化）
Call Delete_RawData(raw_sheet)
'月単位で流量データを取得する
Do
Debug.Print d
begin_of_month = DateSerial(Year(d), Month(d), 1)
end_of_month = DateSerial(Year(d), Month(d) + 1, 0)
'スクレイピング用URLを定義
url1 = "URL;http://www1.river.go.jp/cgi-bin/DspWaterData.exe?KIND=" & data_info(4) & "&ID=" & observatory & "&BGNDATE=" & Replace(d, "/", "") & "&ENDDATE=" & Replace(end_of_month, "/", "") & "&KAWABOU=NO"
rul2 = "DspWaterData.exe?KIND=" & data_info(4) & "&ID=" & observatory & "&BGNDATE=" & Replace(d, "/", "") & "&ENDDATE=" & Replace(end_of_month, "/", "") & "&KAWABOU=NO"
Debug.Print url1
Debug.Print rul2
'データ取得
Worksheets(raw_sheet).Activate
With ActiveSheet.QueryTables.Add(Connection:=url1, Destination:=Worksheets(raw_sheet).Range("$A$1"))
.Name = rul2
.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
Debug.Print "read out"
'データの開始位置を取得
begin_data = 8
'生データの整理
'整理済みのデータ数を取得
Do
If Worksheets("集計データ").Cells(cnt_output, 1) = "" Then
Exit Do
End If
cnt_output = cnt_output + 1
Loop
'データラベルの作成
If d = begin_date Then
Worksheets(calc_sheet).Cells(1, 1) = "日時"
If data_info(4) = 6 Then
Worksheets(calc_sheet).Cells(1, 2) = "流量(" & Replace(Worksheets(raw_sheet).Cells(6, 1), "単位：", "") & ")"
ElseIf data_info(4) = 2 Then
Worksheets(calc_sheet).Cells(1, 2) = "水位(" & Replace(Worksheets(raw_sheet).Cells(6, 1), "単位：", "") & ")"
End If
End If
'データの整理
i = begin_data
For i = begin_data To begin_data + Day(end_of_month) - 1
For j = 2 To 25
Worksheets(calc_sheet).Cells(cnt_output, 1).NumberFormatLocal = "yyyy/m/d h:mm:ss"
Worksheets(calc_sheet).Cells(cnt_output, 1) = Worksheets(raw_sheet).Cells(i, 1) & " " & j - 1 & ":00:00"
Worksheets(calc_sheet).Cells(cnt_output, 2) = Worksheets(raw_sheet).Cells(i, j)
cnt_output = cnt_output + 1
Next j
Next i
'スクレイピングした生データを削除
Call Delete_RawData(raw_sheet)
d = DateAdd("m", 1, d)
Loop Until d > end_date + 1
Worksheets("ハイドログラフ").Activate
'画面更新を再開する
Application.ScreenUpdating = True
End Function
標準モジュールには以下のコードを入れています．
Sub ボタン1_Click()
UserForm1.Show vbModeless
End Sub
Sub ResetAggregatedData()
Application.ScreenUpdating = False
Worksheets("集計データ").Activate
Columns("A:B").Select
Range("B1").Activate
Selection.ClearContents
Worksheets("使い方").Activate
Application.ScreenUpdating = True
End Sub
Sub GraphUpdate(ByVal DATA_TYPE As Integer)
'現在のシート上の全てのグラフに対して適用
Dim cht As Object, n As String, k As String, sn As Integer, L1 As Integer, L2 As Integer
Dim QR As Long '流量データの最終行
QR = Worksheets("集計データ").Range("A2").End(xlDown).Row
k = Worksheets("ハイドログラフ").Name
Application.ScreenUpdating = False
For Each cht In ActiveSheet.ChartObjects
cht.Select
n = ActiveChart.Name
n = Replace(n, k & " グラフ ", "")
ActiveSheet.ChartObjects("グラフ " & n).Activate
'グラフ用データを更新
ActiveChart.FullSeriesCollection(1).Select
Selection.Formula = "=SERIES(,集計データ!R2C1:R" & QR & "C1,集計データ!R2C2:R" & QR & "C2,1)"
'軸の単位を揃える
ActiveChart.Axes(xlValue, xlPrimary).MaximumScaleIsAuto = True
ActiveChart.Axes(xlValue, xlPrimary).MajorUnitIsAuto = True
ActiveChart.Axes(xlValue, xlPrimary).MinimumScaleIsAuto = True
If DATA_TYPE = 6 Then
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "流量Q (m3/s)"
ElseIf DATA_TYPE = 2 Then
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "水位H (m)"
End If
Next
Application.ScreenUpdating = True
End Sub
