過去の気象データ検索からのデータ取得

-
1.概要

気象庁ホームページが最近、大幅なサイトリニューアルにより、色んな情報がビジュアル化されて分かりやすくなっています。従来の表示方法も気に入ってはいたのですが、 地図をベースとした利用者の地域に密着したものに改訂されています。気象や地震情報は日々の暮らしに欠かせないものです。また、過去の統計データなども、 防災や減災対策に役に立つものです。今回は、気象庁の公開データの「過去の気象データ検索」から日ごとの値を取得してグラフ化して見ます。


2.利用方法

Excel VBAマクロの気象庁_気象情報自動取得.xlsmを起動します。

(1)取得期間をプルダウンで、開始年月と終了年月を設定します。
     ※1ヶ月分のみの場合は、開始、終了共に同じ年月を設定します。
(2)実行ボタンをクリックします。
(3)取得データと共に6種類のグラフを描画して結果をブック形式で外部出力します。

気象庁の過去の気象データは、1976年から取得できますが、都道府県の気象台や観測所での観測開始時期が異なるので、 必ずしも、全国一律に取得(データ蓄積)できるかどうかは、未確認です。
3.ソースコード

ソースコードは曜日(土、日)や日付の色分けと6つのグラフの描画部分などがあり、標準モジュール : IEAutoは非常に冗長となっていますが、 全リストを掲載しています。データ取得は、東京をデフォルトとして設定していますので、他の都道府県の地域を指定する場合は、 下記の都道府県のprec_noとblock_noの指定が必要となります。 気象台や観測所が都道府県によって複数ありますが、各都道府県の中の気象台を1つのみ選択して表に纏めたものです。 標準モジュール : IEAutoの65行目と66行目をそれぞれ変更して下さい。元々、他の地域のデータ取得を考慮していなかったので、 お手数ですが、該当ソースコード部分を直接変更して下さい。

都道府県地域prec_noblock_no
01 : 北海道北海道(釧路)－釧路1947418
02 : 青森県青森県－青森3147575
03 : 岩手県岩手県－盛岡3347584
04 : 宮城県宮城県－仙台3447590
05 : 秋田県秋田県－秋田3247582
06 : 山形県山形県－山形3547588
07 : 福島県福島県－福島3647595
08 : 茨城県茨城県－水戸4047629
09 : 栃木県栃木県－宇都宮4147615
10 : 群馬県群馬県－前橋4247624
11 : 埼玉県埼玉県－熊谷4347626
12 : 千葉県千葉県－千葉4547682
13 : 東京都東京都－東京4447662
14 : 神奈川県神奈川県－横浜4647670
15 : 山梨県山梨県－甲府4947638
16 : 長野県長野県－長野4847610
17 : 新潟県新潟県－新潟5447604
18 : 富山県富山県－富山5547607
19 : 石川県石川県－金沢5647605
20 : 福井県福井県－福井5747616
21 : 岐阜県岐阜県－岐阜5247632
22 : 静岡県静岡県－静岡5047656
23 : 愛知県愛知県－名古屋5147636
24 : 三重県三重県－四日市5347684
25 : 滋賀県滋賀県－彦根6047761
26 : 京都府京都府－京都6147759
27 : 大阪府大阪府－大阪6247772
28 : 兵庫県兵庫県－神戸6347770
29 : 奈良県奈良県－奈良6447780
30 : 和歌山県和歌山県－和歌山6547777
31 : 鳥取県鳥取県－鳥取6947746
32 : 島根県島根県－松江6847741
33 : 岡山県岡山県－岡山6647768
34 : 広島県広島県－広島6747765
35 : 山口県山口県－山口8147784
36 : 徳島県徳島県－徳島7147895
37 : 香川県香川県－高松7247891
38 : 愛媛県愛媛県－松山7347887
39 : 高知県高知県－高知7447893
40 : 福岡県福岡県－博多8247807
41 : 佐賀県佐賀県－佐賀8547813
42 : 長崎県長崎県－長崎8447817
43 : 熊本県熊本県－熊本8647819
44 : 大分県大分県－大分8347815
45 : 宮崎県宮崎県－宮崎8747830
46 : 鹿児島県鹿児島県－鹿児島8847827
47 : 沖縄県沖縄県－沖縄9147936

ThisWorkbookは、ブック起動時に各コンボボックスに開始年月、終了年月の 初期値をセットする処理です。この処理は、当ブログの他の記事のExcel VBAマクロでも利用しています。コードの 使いまわしです。設定できる範囲は、1976年から2025年まで作成しています。 
Option Explicit

'***** ブックを開いたときの自動処理 (取得期間設定用のプルダウン処理) *****
Private Sub Workbook_Open()
    '***** 開始統計年 (1976年～2020年までを作成) *****
    Dim CBYear(50)   '配列は 2026年分まで確保 (設定は2025年まで)
    Dim StartYear As Integer
    
    For StartYear = 0 To 49
        CBYear(StartYear) = 1976 + StartYear
    Next
    
    Worksheets("MAIN").BSetYear.List = CBYear
    
    '***** 起動時のデフォルト開始年をセット *****
    For StartYear = 0 To 49
        If CBYear(StartYear) = Year(Date) Then
            Worksheets("MAIN").BSetYear.ListIndex = StartYear
            Exit For
        Else
            Worksheets("MAIN").BSetYear.ListIndex = 0
        End If
    Next

    '***** 開始統計月 *****
    Dim CBMonth(11) As String
    Dim StartMonth As Integer
    
    For StartMonth = 0 To 11
        CBMonth(StartMonth) = Format(1 + StartMonth, "00")
    Next
    
    Worksheets("MAIN").BSetMonth.List = CBMonth
    
    '***** 起動時のデフォルト開始月をセット *****
    For StartMonth = 0 To 11
        If CBMonth(StartMonth) = Right("0" & Month(Date), 2) Then
            Worksheets("MAIN").BSetMonth.ListIndex = StartMonth
            Exit For
        Else
            Worksheets("MAIN").BSetMonth.ListIndex = 0
        End If
    Next

    '***** 終了統計年 (1976年～2025年までを作成) *****
    For StartYear = 0 To 49
        CBYear(StartYear) = 1976 + StartYear
    Next
    
    Worksheets("MAIN").ESetYear.List = CBYear
    
    '***** 起動時のデフォルト終了年をセット *****
    For StartYear = 0 To 49
        If CBYear(StartYear) = Year(Date) Then
            Worksheets("MAIN").ESetYear.ListIndex = StartYear
            Exit For
        Else
            Worksheets("MAIN").ESetYear.ListIndex = 0
        End If
    Next

    '***** 終了統計月 *****
    For StartMonth = 0 To 11
        CBMonth(StartMonth) = Format(1 + StartMonth, "00")
    Next
    
    Worksheets("MAIN").ESetMonth.List = CBMonth
    
    '***** 起動時のデフォルト終了月をセット *****
    For StartMonth = 0 To 11
        If CBMonth(StartMonth) = Right("0" & Month(Date), 2) Then
            Worksheets("MAIN").ESetMonth.ListIndex = StartMonth
            Exit For
        Else
            Worksheets("MAIN").ESetMonth.ListIndex = 0
        End If
    Next
End Sub
Sheet1(MAIN)は、シート上に配置された各コンボボックスの値を 取得して、指定期間の月数を求める処理と指定範囲の誤りの合理性チェックをする処理です。 実行ボタンがクリックされると、指定パラメータを渡して、標準モジュール(IEAuto)の自動巡回ルーチン をコールして取得処理を開始します。 
Option Explicit

Private Sub BRStart_Click()
   '***** 指定期間の月数を求める *****
    
    Dim dBeginDate As Date
    Dim dEndDate As Date
    Dim intMonths As Integer

    ' コンボボックスの値を変数に退避しておく
    Dim BYY As Integer
    Dim EYY As Integer
    Dim BMM As Integer
    Dim EMM As Integer

    '開始年 ... Worksheets("MAIN").BSetYear.Text
    '開始月 ... Worksheets("MAIN").BSetMonth.Text
    '終了年 ... Worksheets("MAIN").ESetYear.Text
    '終了月 ... Worksheets("MAIN").ESetMonth.Text

    BYY = Val(Worksheets("MAIN").BSetYear.Text)
    BMM = Val(Worksheets("MAIN").BSetMonth.Text)
    EYY = Val(Worksheets("MAIN").ESetYear.Text)
    EMM = Val(Worksheets("MAIN").ESetMonth.Text)

    '***** 設定年月のエラー判定 *****

    ' 開始年の判定
    If BYY > Year(Date) Then
       MsgBox "開始年の設定が間違っています。当年以前を設定して下さい。"
       Exit Sub
    End If
    ' 開始年月の判定
    If (BYY = Year(Date)) And (BMM > Month(Date)) Then
       MsgBox "開始月の設定が間違っています。当年、当月以前を設定して下さい。"
       Exit Sub
    End If
    ' 終了年の判定
    If EYY > Year(Date) Then
       MsgBox "終了年の設定が間違っています。当年以前を設定して下さい。"
       Exit Sub
    End If
    ' 終了年月の判定
    If (EYY = Year(Date)) And (EMM > Month(Date)) Then
       MsgBox "終了月の設定が間違っています。当年、当月以前を設定して下さい。"
       Exit Sub
    End If

    ' Beginning date.
    dBeginDate = DateValue(Str(BMM) & "/" & 1 & "/" & Str(BYY))
    ' Ending Date.
    dEndDate = DateValue(Str(EMM) & "/" & 1 & "/" & Str(EYY))

    ' 当月を含む期間の月数計算
    intMonths = (((Year(dEndDate) - Year(dBeginDate)) * 12) + _
       Month(dEndDate) - Month(dBeginDate)) + 1

    '***** IE自動巡回ルーチンへ (IEAuto) *****
    Call IE_open(intMonths, BYY, BMM, EYY, EMM)
End Sub

標準モジュール : IEAutoが実際にデータを取得するメインの部分となります。 プルダウンで指定された取得年月の値をパラメータとして、URLへ渡してナビゲートを開始します。 取得ページが見つかったら、そのページのHTMLの<TABLE>タグからデータを抜出しシート上に書き出します。 その際に ) や ] などの記号が数値データ内に含まれている場合があるので、グラフ処理の時に値として認識されないので 除去します。ここで、いったん新規に空のブックを作成して、取得したデータをコピーし、そのシート上で グラフなどを作成して外部ファイルとして出力します。 

'***************************************************************************
'*   気象庁_気象情報自動取得.xlsm Ver4.0
'*
'*   気象庁 - 過去の気象データ検索からのデータ取得 (自動巡回版)
'*
'*   取得先 : https://www.data.jma.go.jp/obd/stats/etrn/index.php
'*
'*
'*   (1)(ブック形式)外部データ出力機能付き
'*   (2)気温(平均、最高、最低)グラフ作成
'*   (3)気圧(現地、海面)グラフ作成
'*   (4)湿度(平均、最小)グラフ作成
'*   (5)日照時間グラフ作成
'*   (6)風速(平均、最大)グラフ作成
'*   (7)降水量(合計、１時間、10分間)グラフ作成
'*
'*   初版 Ver1.0  2012.04.13 Excel2007で作成
'*   改訂 Ver2.0  2013.08.27
'*   改訂 Ver3.0  2013.09.13
'*   改訂 Ver4.0  2018.03.06 Excel2016に対応
'*
'***************************************************************************

Option Explicit

'***** 32bit版を利用の場合は、API宣言部の PtrSafe を削除して下さい。 (Excel2010以降は、このままでも大丈夫のはずです。) *****

' Sleep API宣言
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'***** インターネット自動巡回 *****
Public Sub IE_open(ByVal repnum As Integer, ByVal Byear As Integer, ByVal Bmonth As Integer _
                 , ByVal Eyear As Integer, ByVal Emonth As Integer)
    Dim URL        As String
    Dim MainURL    As String
    Dim StartYear  As String
    Dim StartMonth As String
    Dim EndYear    As String
    Dim EndMonth   As String
    Dim strText    As String
    Dim rop        As Integer
    Dim objIE      As Object
    
    Dim ProcNo, blockno, precch, blockch As Integer
    
    On Error Resume Next

    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = False

    '***** 初期起動ページ表示 *****
    URL = "https://www.data.jma.go.jp/obd/stats/etrn/index.php"
    objIE.Navigate URL
  
    Do While objIE.ReadyState <> 4
       Do While objIE.Busy = True
          DoEvents
       Loop
    Loop

    objIE.Visible = False

    '***** URL東京都設定 *****
    MainURL = "https://www.data.jma.go.jp/obd/stats/etrn/view/daily_s1.php?"
    ProcNo = "44"
    blockno = "47662"
    
    '====================================================================
    ' ※デフォルトは東京に設定してあるので、他の地域を取得したい場合は、
    '   ProcNo とblockno を変更のこと。
    '====================================================================

    '***** 開始年をセット *****
    StartYear = Trim(Str(Byear))
    '***** 開始月を2桁にする *****
    If Bmonth < 10 Then
       StartMonth = Trim(Format(Str(Bmonth), "00"))
       Else
       StartMonth = Trim(Str(Bmonth))
    End If

    '▼▼▼▼▼ ここから繰り返し処理開始 ▼▼▼▼▼

    '***** 自動巡回開始 *****
    For rop = 1 To repnum
       ' ***** URLを合成 *****
       URL = MainURL & "prec_no=" & ProcNo _
             & "&prec_ch=" & precch _
             & "&block_no=" & blockno _
             & "&block_ch=" & blockch _
             & "&year=" & StartYear _
             & "&month=" & StartMonth _
             & "&day=&view=p1"

       
       ' 設定期間範囲に従い、順次ナビゲート
       objIE.Navigate URL
    
       ' ページが完全に表示されるまで待つ
       Do While objIE.ReadyState <> 4
          Do While objIE.Busy = True
             DoEvents
          Loop
       Loop

       ' 0.5秒 Wait
       Sleep (500)
       
       '***** データ取得処理 (シートに編集後データ書き出し) *****
       ' Web上(HTML内)の表のタイトル名を取得
       Dim objCap As Object
       Set objCap = objIE.Document.getElementsByTagName("H3")
       
       Dim q As Integer

       strText = ""
       For q = 0 To objCap.Length - 1
          strText = objCap(q).InnerTEXT
          If strText <> "" Then
            Exit For
          End If
       Next

       ' H3で取得したタイトル名を E4セルに表示
       Range("E4") = Trim(Mid(strText, 1, Len(strText) - 12))
       ' ***** HTML内からテーブルタグを探す *****
       ' タグの取出しが、.tags("タグの名前")でできるので、

       Dim objTABLE As Object                           ' TABLEの格納用
       Set objTABLE = objIE.Document.all.tags("TABLE")  ' .tags("TABLE")でTABLEタグを抜く
       '↑テーブルを取り出す｡
    
       ' 1行目のデータを取り出す｡
       ' objTABLE(n).rows(0).cells(x).innertext
       Dim n As Integer        ' n番目の表
       Dim x As Integer        ' 列の管理
       Dim Y As Integer        ' 行の管理
       Dim nTARGET As Integer  ' 見つけた表の番号
       Dim strMOJI As String
    
       nTARGET = -1                                              ' 初期値が見つからなかった-１とする
       For n = 0 To objTABLE.Length - 1                          ' テーブルの数ループする。
           For x = 0 To objTABLE(n).Rows(0).Cells.Length - 1     ' 列数分ループ
               strMOJI = objTABLE(n).Rows(0).Cells(x).InnerTEXT  ' 値を代入
               strMOJI = Replace(strMOJI, vbCr, "")              ' 改行コードを消す 0x0d 0x0a
               strMOJI = Replace(strMOJI, vbLf, "")
            
               ' TD や TH の最初の表題名と比較する
               If strMOJI = "日" Then
                   nTARGET = n  '表の番号をセット保存。
                   Exit For
               End If
           Next
           If nTARGET <> -1 Then Exit For
       Next
       ' <TABLE>タグが見つからない場合
       If nTARGET = -1 Then
            MsgBox "該当データが見つかりません。"
            Exit Sub
       End If

       ' ***** 目的の表を見つけたらシートに書き出す｡ シート名 : MAIN とする。 *****
       Sheets("MAIN").Select  'シートを切り替える
       Worksheets("MAIN").Activate
       Sheets("MAIN").Select
       Range("A9").Select
 
       '* ***** 【重要】Webの表をシートへ転記(代入する) *******************************
       '*
       '* 行と列の開始位置は、TABLEタグの表題(項目名)を含んだ部分からとなるので
       '* デフォルトでは、
       '*    y = 0
       '*    x = 0
       '* としているが、今回は、Excelシート側で表題(項目名)部分は、固定化して整形
       '* しているので、データ部分のみを取得させるとして、y , x の値を変更している。
       '* 実際は、シートの5～8行目までを項目名として、データは、9行目からコピーする
       '* にしている。
       '*
       '* For y = 0 To objTABLE(nTARGET).Rows.Length - 1                ' 行のループ
       '*     For x = 0 To objTABLE(nTARGET).Rows(y).Cells.Length - 1   ' 列数分ループ
       '*         Cells(y + 1, x + 1) = objTABLE(nTARGET).Rows(y).Cells(x).innertext
       '*     Next
       '* Next
       '*
       '* *****************************************************************************

       ' シートデータをクリア (セルの属性定義を維持したままデータのみを削除)
       If Range("A9") <> "" Then
          Range("A9:U39").SpecialCells(xlCellTypeConstants, 23).ClearContents
       End If

       ' ***** Webの表をシートへ転記(代入する) *****
       For Y = 4 To objTABLE(nTARGET).Rows.Length - 1                ' 行のループ
            For x = 0 To objTABLE(nTARGET).Rows(Y).Cells.Length - 1  ' 列数分ループ
            
                ' TABLEタグのデータは、4行目から開始し、シートの9行目から転記する
                Cells(Y + 5, x + 1) = objTABLE(nTARGET).Rows(Y).Cells(x).InnerTEXT
             
                '●●●●●　データ内の不当なものを除去する処理  ●●●●●
                ' (1)データに括弧が付く場合があるので除去する
                If Right(Cells(Y + 5, x + 1), 2) = " )" Then
                    Cells(Y + 5, x + 1) = Left(Cells(Y + 5, x + 1), Len(Cells(Y + 5, x + 1)) - 2)
                End If
                ' (2)データに括弧が付く場合があるので除去する
                If Right(Cells(Y + 5, x + 1), 2) = " ]" Then
                    Cells(Y + 5, x + 1) = Left(Cells(Y + 5, x + 1), Len(Cells(Y + 5, x + 1)) - 2)
                End If
                ' データに--が付く場合があるので除去する
                If Cells(Y + 5, x + 1) = "--" Then
                    Cells(Y + 5, x + 1) = "0.0"
                End If
                ' データに×が付く場合があるので除去する
                If Cells(Y + 5, x + 1) = "×" Then
                    Cells(Y + 5, x + 1) = "0.0"
                End If
            Next
       Next

       ' ▲▲▲▲▲ データ取得終了 ▲▲▲▲▲

       '***** コピーする範囲を指定 *****
       Dim range1 As Range
       Set range1 = Range("A5:U39")
       range1.Copy
    
       '***** シート名を作成 *****
       Dim SheetName As String, HeadName As String
       Dim k As Integer, j As Integer
       Dim bookname As String
    
       HeadName = Range("E4")
       k = InStr(HeadName, "　")
       j = Len(HeadName)
       SheetName = Mid(HeadName, k + 1, j - k)
       Workbooks.Add                   ' 新規ブックを追加
       bookname = ActiveWorkbook.Name  ' 新規ブック名を取得
       Workbooks(bookname).Activate    ' 新規ブックをアクティブ

       'Application.ScreenUpdating = False
       Application.WindowState = xlMinimized


       Sheets.Add                      ' シートを新規追加する
       ActiveSheet.Name = SheetName    ' シートに名前を付ける

       '***** 新しく追加したワークシートをアクティブにする *****
       Worksheets(SheetName).Activate
       Sheets(SheetName).Select
       Range("A1").Value = HeadName
       Range("A2").Select

       '***** 形式を指定して貼り付け (フォーマット情報) *****
       Range("A2").PasteSpecial Paste:=xlPasteColumnWidths, _
       Operation:=xlPasteSpecialOperationNone
       ' 形式を指定して貼り付け (すべての情報)
       Range("A2").PasteSpecial Paste:=xlPasteAll, _
       Operation:=xlPasteSpecialOperationNone, _
       Transpose:=False
       Application.CutCopyMode = False
       
       '***** Excel2016対策 (デフォルトのフォントで影響を受けるのを防止) *****
       Cells.Select
       With Selection.Font
          .Name = "ＭＳ Ｐゴシック"
          .Size = 10
       End With
       
       Rows("1:1").Select
       Selection.RowHeight = 22.5
       Rows("2:2").Select
       Rows("2:300").Select
       Selection.RowHeight = 13.5
       
       Range("A2").Select
    
       ' 不要なSheet1～Sheet3を削除する
       Call DelBlankSheet

       ' ***** B列を挿入して曜日の項目を追加する *****
       Columns("B:B").Select
       Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
       Columns("C:C").Select
       Selection.Delete Shift:=xlToLeft
       Range("B2:B5").Select
       Selection.Merge
       Range("B2:B5").Select
       ActiveCell.FormulaR1C1 = "曜日"
       Range("B2:B5").Select
       With Selection
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .WrapText = False
           .Orientation = xlVertical
           .AddIndent = False
           .IndentLevel = 0
           .ShrinkToFit = False
           .ReadingOrder = xlContext
           .MergeCells = True
       End With

       '***** 挿入したB列の背景色を塗りつぶしなしに設定する *****
       Range("B6:B36").Select
       With Selection.Interior
           .Pattern = xlNone
           .TintAndShade = 0
           .PatternTintAndShade = 0
       End With

       '***** A列の背景色を塗りつぶしなしに設定する *****
       Range("A6:A36").Select
       With Selection.Interior
           .Pattern = xlNone
           .TintAndShade = 0
           .PatternTintAndShade = 0
       End With
    
       '***** 月末日を取得 (閏年を考慮済み) *****
       Dim dd As Integer, TempYear As String, TempMonth As String
    
       '***** 年月が入っているシート名から、yyyyとmmをそれぞれ取得 *****
       TempYear = Mid(SheetName, InStr(SheetName, "年") - 4, 4)
       TempMonth = Mid(SheetName, InStr(SheetName, "年") + 1, 2)
       If Mid(TempMonth, 2, 1) = "月" Then
          TempMonth = Left(TempMonth, 1)
       End If
       '***** 月末日 *****
       dd = GetLastDay(Val(TempYear), Val(TempMonth))
    
       '***** 年月日から曜日を取得 *****
       Dim DTemp As Date, TempDate As Date, Youbi As String, p As Integer
       Dim stat As Boolean, hh As String

       Worksheets(SheetName).Activate
       Sheets(SheetName).Select
    
       '***** 1日～月末日までループして曜日を設定 *****
       For p = 1 To dd
           hh = ""
           DTemp = TempYear & "/" & TempMonth & "/" & p
           TempDate = DateSerial(Val(TempYear), Val(TempMonth), p)
           
           ' 各月の開始曜日
           Youbi = Left(WeekdayName(Weekday(DTemp)), 1)
          
           ' 土、日の場合の色分け
           If Youbi = "土" Then
              ' 土曜日の場合
              Range("B5").Offset(p, 0).Select
              Call DayColSet(12611584)
              Range("B5").Offset(p, 0).Value = Youbi
           ElseIf Youbi = "日" Then
              Range("B5").Offset(p, 0).Select
              ' 日曜日の場合
              Call DayColSet(255)
              Range("B5").Offset(p, 0).Value = Youbi
           Else
              Range("B5").Offset(p, 0).Select
              Call OtherColSet
              Range("B5").Offset(p, 0).Value = Youbi
           End If
       Next

       ' 日付の色分け
       For p = 1 To dd
           hh = ""
           DTemp = TempYear & "/" & TempMonth & "/" & p
           TempDate = DateSerial(Val(TempYear), Val(TempMonth), p)
           
           ' 各月の開始曜日
           Youbi = Left(WeekdayName(Weekday(DTemp)), 1)

           ' 土、日の場合の色分け
           If Youbi = "土" Then
              ' 土曜日の場合
              Range("A5").Offset(p, 0).Select
              Call DayColSet(12611584)
           ElseIf Youbi = "日" Then
              Range("A5").Offset(p, 0).Select
              ' 日曜日の場合
              Call DayColSet(255)
           Else
              Range("A5").Offset(p, 0).Select
              Call OtherColSet
           End If
       Next

       '***** グラフ作成関連（合計6つのグラフを同時作成） *****
       
       ' ▼▼▼▼▼▼ ここからグラフ作成開始 ▼▼▼▼▼▼
       Dim nRange As String
       Dim nPosL As Integer, nPosTop As Integer, nWidth As Integer, nHeight As Integer
       Dim GType As Long

       ' 気温(平均、最高、最低)グラフの値の範囲 (セルの範囲を指定)
       Select Case dd
          Case 28
               nRange = "H6:J33"
          Case 29
               nRange = "H6:J34"
          Case 30
               nRange = "H6:J35"
          Case 31
               nRange = "H6:J36"
          Case Else
               nRange = "H6:J36"
       End Select

       ' 気温(平均、最高、最低)グラフ関連生成パラメータ
       nPosL = 20              ' 描画位置     : Left
       nPosTop = 520           ' 描画位置     : Top
       nWidth = 800            ' グラフサイズ : Width
       nHeight = 260           ' グラフサイズ : Height
       GType = xlLineMarkers   ' チャート種類 : 折れ線グラフ
    
       '● 気温(平均、最高、最低)グラフを生成
       Call GraphGen(nRange, GType, nPosL, nPosTop, nWidth, nHeight, 1, 1)

       ' 気温(平均、最高、最低)系列名の設定とレイアウトの再設定
       With ActiveChart
          .SeriesCollection(1).Name = "=""平均"""
          .SeriesCollection(2).Name = "=""最高"""
          .SeriesCollection(3).Name = "=""最低"""
          .ApplyLayout (5)
          .ChartTitle.Select
          Selection.Delete
          .Axes(xlValue).AxisTitle.Select
          Selection.Delete
       End With

       ' データテーブルのフォント変更
       ActiveChart.DataTable.ShowLegendKey = True
       ActiveChart.DataTable.Select
       Selection.AutoScaleFont = True

       With ActiveChart.DataTable
            .ShowLegendKey = True
            .Font.Size = 9
            .Font.Name = "ＭＳ Ｐゴシック"
       End With

       ' グラフタイトル付加
       Range("C38").Select
       Range("C38").Value = "気温(平均、最高、最低)  単位：(℃)"
       Selection.Font.Bold = True

       ' 気圧(現地、海面)グラフの値の範囲 (セルの範囲を指定)
       Select Case dd
          Case 28
               nRange = "C6:D33"
          Case 29
               nRange = "C6:D34"
          Case 30
               nRange = "C6:D35"
          Case 31
               nRange = "C6:D36"
          Case Else
               nRange = "C6:D36"
       End Select

       ' 気圧(現地、海面)グラフ関連生成パラメータ
       nPosL = 20              ' 描画位置     : Left
       nPosTop = 820           ' 描画位置     : Top
       nWidth = 800            ' グラフサイズ : Width
       nHeight = 260           ' グラフサイズ : Height
       GType = xlLineMarkers   ' チャート種類 : 折れ線グラフ
    
       '● 気圧(現地、海面)グラフを生成
       Call GraphGen(nRange, GType, nPosL, nPosTop, nWidth, nHeight, 1, 1)

       ' 気圧(現地、海面)系列名の設定とレイアウトの再設定
       With ActiveChart
          .SeriesCollection(1).Name = "=""現地"""
          .SeriesCollection(2).Name = "=""海面"""
          .ApplyLayout (1)
          .ChartTitle.Select
          Selection.Delete
          .Axes(xlValue).AxisTitle.Select
          Selection.Delete
       End With

       ' グラフタイトル付加
       Range("C60").Select
       Range("C60").Value = "気圧(現地、海面)  単位：(hPa)"
       Selection.Font.Bold = True

       ' 湿度(平均、最小)グラフの値の範囲 (セルの範囲を指定)
       Select Case dd
          Case 28
               nRange = "K6:L33"
          Case 29
               nRange = "K6:L34"
          Case 30
               nRange = "K6:L35"
          Case 31
               nRange = "K6:L36"
          Case Else
               nRange = "K6:L36"
       End Select

       ' 湿度(平均、最小)グラフ関連生成パラメータ
       nPosL = 20                  ' 描画位置     : Left
       nPosTop = 1120              ' 描画位置     : Top
       nWidth = 800                ' グラフサイズ : Width
       nHeight = 260               ' グラフサイズ : Height
       GType = xlColumnClustered   ' チャート種類 : 縦棒グラフ
    
       '● 湿度(平均、最小)グラフを生成
       Call GraphGen(nRange, GType, nPosL, nPosTop, nWidth, nHeight, 1, 1)

       ' 湿度(平均、最小)系列名の設定とレイアウトの再設定
       With ActiveChart
          .SeriesCollection(1).Name = "=""平均"""
          .SeriesCollection(2).Name = "=""最小"""
          .SeriesCollection(1).Interior.ColorIndex = 43
          .SeriesCollection(2).Interior.ColorIndex = 47
          .ApplyLayout (5)
          .ChartTitle.Select
          Selection.Delete
          .Axes(xlValue).AxisTitle.Select
          Selection.Delete
       End With
       ' グラフ間隔(幅)の調整
       ActiveChart.ChartGroups(1).GapWidth = 50

       ' データテーブルのフォント変更
       ActiveChart.DataTable.ShowLegendKey = True
       ActiveChart.DataTable.Select
       Selection.AutoScaleFont = True

       With ActiveChart.DataTable
            .ShowLegendKey = True
            .Font.Size = 9
            .Font.Name = "ＭＳ Ｐゴシック"
       End With

       ' グラフタイトル付加
       Range("C82").Select
       Range("C82").Value = "湿度(平均、最小)  単位：(%)"
       Selection.Font.Bold = True

       ' 日照時間グラフの値の範囲 (セルの範囲を指定)
       Select Case dd
          Case 28
               nRange = "R6:R33"
          Case 29
               nRange = "R6:R34"
          Case 30
               nRange = "R6:R35"
          Case 31
               nRange = "R6:R36"
          Case Else
               nRange = "R6:R36"
       End Select

       ' 日照時間グラフ関連生成パラメータ
       nPosL = 20                  ' 描画位置     : Left
       nPosTop = 1420              ' 描画位置     : Top
       nWidth = 800                ' グラフサイズ : Width
       nHeight = 260               ' グラフサイズ : Height
       GType = xlColumnClustered   ' チャート種類 : 縦棒グラフ
    
       '● 日照時間グラフを生成
       Call GraphGen(nRange, GType, nPosL, nPosTop, nWidth, nHeight, 1, 1)

       ' 日照時間系列名の設定とレイアウトの再設定
       With ActiveChart
          .SeriesCollection(1).Name = "=""日照時間"""
          .SeriesCollection(1).Interior.ColorIndex = 45
          .ApplyLayout (5)
          .ChartTitle.Select
          Selection.Delete
          .Axes(xlValue).AxisTitle.Select
          Selection.Delete
       End With
       ' グラフ間隔(幅)の調整
       ActiveChart.ChartGroups(1).GapWidth = 50

       ' データテーブルのフォント変更
       ActiveChart.DataTable.ShowLegendKey = True
       ActiveChart.DataTable.Select
       Selection.AutoScaleFont = True

       With ActiveChart.DataTable
            .ShowLegendKey = True
            .Font.Size = 9
            .Font.Name = "ＭＳ Ｐゴシック"
       End With

       ' グラフタイトル付加
       Range("C105").Select
       Range("C105").Value = "日照時間  単位：(h)"
       Selection.Font.Bold = True

       ' 風速(平均、最大)グラフの値の範囲 (セルの範囲を指定)
       Select Case dd
          Case 28
               nRange = "M6:N33"
          Case 29
               nRange = "M6:N34"
          Case 30
               nRange = "M6:N35"
          Case 31
               nRange = "M6:N36"
          Case Else
               nRange = "M6:N36"
       End Select

       '● 風速(平均、最大)グラフ関連生成パラメータ
       nPosL = 20              ' 描画位置     : Left
       nPosTop = 1720          ' 描画位置     : Top
       nWidth = 800            ' グラフサイズ : Width
       nHeight = 260           ' グラフサイズ : Height
       GType = xlLineMarkers   ' チャート種類 : 折れ線グラフ
    
       ' グラフを生成
       Call GraphGen(nRange, GType, nPosL, nPosTop, nWidth, nHeight, 1, 1)

       ' 風速(平均、最大)系列名の設定とレイアウトの再設定
       With ActiveChart
          .SeriesCollection(1).Name = "=""平均風速"""
          .SeriesCollection(2).Name = "=""最大風速"""
          .ApplyLayout (5)
          .ChartTitle.Select
          Selection.Delete
          .Axes(xlValue).AxisTitle.Select
          Selection.Delete
       End With

       ' データテーブルのフォント変更
       ActiveChart.DataTable.ShowLegendKey = True
       ActiveChart.DataTable.Select
       Selection.AutoScaleFont = True

       With ActiveChart.DataTable
            .ShowLegendKey = True
            .Font.Size = 9
            .Font.Name = "ＭＳ Ｐゴシック"
       End With

       ' グラフタイトル付加
       Range("C127").Select
       Range("C127").Value = "風速(平均、最大)  単位：(m/s)"
       Selection.Font.Bold = True

       ' 降水量(合計、１時間、10分間)グラフの値の範囲 (セルの範囲を指定)
       Select Case dd
          Case 28
               nRange = "E6:G33"
          Case 29
               nRange = "E6:G34"
          Case 30
               nRange = "E6:G35"
          Case 31
               nRange = "E6:G36"
          Case Else
               nRange = "E6:G36"
       End Select

       ' 降水量(合計、１時間、10分間)グラフ関連生成パラメータ
       nPosL = 20                  ' 描画位置     : Left
       nPosTop = 2020              ' 描画位置     : Top
       nWidth = 800                ' グラフサイズ : Width
       nHeight = 260               ' グラフサイズ : Height
       GType = xlColumnClustered   ' チャート種類 : 縦棒グラフ
    
       '● 降水量(合計、１時間、10分間)グラフを生成
       Call GraphGen(nRange, GType, nPosL, nPosTop, nWidth, nHeight, 1, 1)

       ' 降水量(合計、１時間、10分間))系列名の設定とレイアウトの再設定
       With ActiveChart
          .SeriesCollection(1).Name = "=""合計"""
          .SeriesCollection(2).Name = "=""１時間"""
          .SeriesCollection(3).Name = "=""10分間"""
          .ApplyLayout (5)
          .ChartTitle.Select
          Selection.Delete
          .Axes(xlValue).AxisTitle.Select
          Selection.Delete
       End With
       ' グラフ間隔(幅)の調整
       'ActiveChart.ChartGroups(1).GapWidth = 50

       ' データテーブルのフォント変更
       ActiveChart.DataTable.ShowLegendKey = True
       ActiveChart.DataTable.Select
       Selection.AutoScaleFont = True

       With ActiveChart.DataTable
            .ShowLegendKey = True
            .Font.Size = 9
            .Font.Name = "ＭＳ Ｐゴシック"
       End With

       ' グラフタイトル付加
       Range("C149").Select
       Range("C149").Value = "降水量(合計、１時間、10分間)  単位：(mm)"
       Selection.Font.Bold = True

       ' ウィンドウ枠を固定
       Range("M6").Select
       ActiveWindow.FreezePanes = True

       ' 表題名を整形する (行の高さとフォントの太字)
       Rows("1:1").RowHeight = 22.5
       Range("A1").Select
       Selection.Font.Bold = True

       ' シートの枠線を非表示
       ActiveWindow.DisplayGridlines = False

       '***** ブック形式で名前を付けて自動保存 *****
       Dim Outbook As Workbook
       Set Outbook = ActiveWorkbook
       Dim OutBookName As String
    
       If Len(TempMonth) = 1 Then
          OutBookName = TempYear & "年" & "0" & TempMonth & "月"
       Else
          OutBookName = TempYear & "年" & TempMonth & "月"
       End If
       Outbook.SaveAs FileName:=ThisWorkbook.Path & "¥" & OutBookName & ".xlsx"

       '***** ブックを閉じる *****
       ActiveWorkbook.Close

       Workbooks("気象情報自動取得.xlsm").Activate
       Set range1 = Nothing
       Set Outbook = Nothing
       Set objCap = Nothing
       Set objTABLE = Nothing

       ' シートデータをクリア (セルの属性定義を維持したままデータのみを削除)
       If Range("A9") <> "" Then
          Range("A9:U39").SpecialCells(xlCellTypeConstants, 23).ClearContents
       End If
       Range("E4") = ""

       ' 期間範囲のインクリメント(終了範囲はループ回数で制限されるので省略)
       Bmonth = Bmonth + 1
       If Bmonth > 12 Then
          Bmonth = 1
          Byear = Byear + 1
          StartYear = Trim(Str(Byear))
       End If
       If Bmonth < 10 Then
          StartMonth = Trim(Format(Str(Bmonth), "00"))
          Else
          StartMonth = Trim(Str(Bmonth))
       End If
    Next rop

    '***** IE object解放 *****
    objIE.Quit
    Set objIE = Nothing
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    MsgBox "データ取得処理が完了しました。"

End Sub

'***** 月末日取得 (年,月) *****
Private Function GetLastDay(nYear As Integer, nMonth As Integer) As Integer
   Dim md As Variant
   ' 月末日
   md = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
   If ((nYear Mod 4 = 0) And (Not nYear Mod 100) Or (nYear Mod 400 = 0)) Then
       md(1) = 29
   End If
   GetLastDay = md(nMonth - 1)
End Function

'***** 不要な空きシートを削除 *****
Private Sub DelBlankSheet()
   Dim DelSheet As Object
   
    Application.DisplayAlerts = False
    For Each DelSheet In Worksheets
        If DelSheet.UsedRange.Address(0, 0) = "A1" And _
            DelSheet.Range("A1").Value = Empty Then
            If Worksheets.Count <> 1 Then
                DelSheet.Delete
            End If
        End If
    Next
    Application.DisplayAlerts = True
End Sub

'***** グラフ生成 (単一グラフ) *****
Private Sub GraphGen(rangeString, graphType, posLeft, posTop, graphWidth, graphHeight, nFlag, pFlag)
   ' rangeString   : 範囲
   ' graphType     : 種類
   ' posLeft       : 左側からの位置
   ' posTop        : 上側からの位置
   ' graphWidth    : グラフ幅
   ' graphHeight   : グラフ高さ
   ' nFlag         : チャートエリアの枠線消去可否
   ' pFlag         : 背景の透明有無

   With ActiveSheet.ChartObjects.Add(posLeft, posTop, graphWidth, graphHeight)
     .Chart.ChartType = graphType
     .Chart.SetSourceData Source:=ActiveSheet.Range(rangeString), PlotBy:=xlColumns
     .Chart.Location where:=xlLocationAsObject, Name:=ActiveSheet.Name
   End With
   
   ' チャートエリアの枠線消去
   If nFlag = 1 Then
       ActiveChart.ChartArea.Select
       With Selection
          .Border.LineStyle = 0
       End With
    End If
    ' プロットエリア、チャートエリアの背景を透明
    If pFlag = 1 Then
       ActiveChart.PlotArea.Interior.ColorIndex = xlColorIndexNone
       ActiveChart.ChartArea.Interior.ColorIndex = xlColorIndexNone
    End If
End Sub

'***** 日付、曜日の色設定 *****
Private Sub DayColSet(nCol As Double)
    With Selection.Font
         .ThemeColor = xlThemeColorDark1
         .TintAndShade = 0
    End With
    With Selection.Interior
         .Pattern = xlSolid
         .PatternColorIndex = xlAutomatic
         .Color = nCol
         .TintAndShade = 0
         .PatternTintAndShade = 0
    End With
End Sub

'***** その他の色設定 *****
Private Sub OtherColSet()
    With Selection.Font
         .ThemeColor = xlThemeColorLight1
         .TintAndShade = 0
    End With
    With Selection.Interior
         .Pattern = xlNone
         .TintAndShade = 0
         .PatternTintAndShade = 0
    End With
End Sub

'***** ブラウザナビゲート *****
Private Sub objIE_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant _
                  , TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
End Sub

'***** ブラウザドキュメント表示 *****
Private Sub objIE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
     dsp_flg = True
     Application.StatusBar = objIE.Document.Title    ' Titleを取得
End Sub
取得済みデータがカレントディレクトリに溜まるので、管理するための専用のフォルダを作成して移動させます。
(例)各年毎のフォルダを作成して、月単位のブックを保管
また、こうして纏められた月単位のブックデータ(1月から12月分)を1つのブックに統合する処理を別記事として紹介する予定としています。

4.ダウンロード

提供するソースコードのライセンスは、CC0 (クレジット表示不要、改変可、商用可) とします。自由に利用して頂いてかまいません。 尚、データの取得やプログラム実行において損害等が生じた場合は、筆者は一切の責任も負いません。全て自己責任でお願いします。

紹介したExcel VBAマクロは、下記よりダウンロードして下さい。

ダウンロード

■関連記事
・過去に取得済み月単位気象データを年単位に統合

コメント

コメントを投稿

このブログの人気の投稿

Excelアドインで日本語形態素解析

-
イメージ
1.概要 日本語形態素解析とは、文法的な情報の注記の無い自然言語のテキストデータ（文）から、対象言語の文法や、辞書と呼ばれる単語の品詞等の情報に基づき、 形態素（Morpheme, おおまかにいえば、言語で意味を持つ最小単位）の列に分割し、それぞれの形態素の品詞等を判別する作業です。（出典:Wikipedia） 形態素解析エンジンとしては、Mecabが有名です。筆者もPythonにインストールして、テキストマイニングに利用しています。しかし、会社などで利用したい 場合は、このような環境を個人的な利用目的で構築するにしても、セキュリティ上の問題などでIT管理者などから利用許可が下りない場合があります。 今回は、普段から利用しているExcelのアドインでテキストマイニングをして見たいと思います。特別なサーバーなどへのインストールなしで、 個人PCにアドインのインストール許可さえもらえれば誰でも簡単にテキストマイニング(ワードクラウド)分析をすることができます。 2.利用方法 (1)Excelのアドインである「E2D3」を追加します。「挿入」→「アドインを入手」をクリックし      「データ分析」を選択して、「E2D3」を探します。見つかったら、「追加」をクリックしま      す。これで、「E2D3」が利用できるようになります。 (2)分析するデータ(テキスト文書)を準備します。 (3)下記サイトの日本語形態素解析サービス(無料ツール)を利用して、文書を解析し品詞毎に分解、      統計データとして出力します。 日本語形態素解析サービス(無料ツール) URL : https://opendata-web.site/tool/parse/ ※ブックマーク等に登録しておくと良いでしょう。 (4)分析するデータ(テキスト文書)をテキストボックスに貼付け、解析ボタンをクリックします。 (5)解析結果が日本語形態素と統計の2種類画面出力されるので、統計の表をコピペして、Excelの      空きシートに一時的に貼り付けます。 (6)フィルタを追加して、品詞で名詞を選択してフィルタリングします。名詞のみのデータになるの      で、フィルタしたシートのB列(出現数)、C列(表記)をコピーして退避し、B列とC列を入れ替え

階層構造JSONファイルの作成

-
イメージ
1.はじめに 仕事や趣味でいろいろなデータを扱いますが、プログラミングで扱うデータ形式も多種多様でデータベース、テキスト、csv、xml、json形式など 思い付くだけで数十種類でてきます。データの見える化 (可視化) をやりたくて階層構造のJSON形式のファイルを扱う必要性があり、 元データ収集・編集 ⇒ Excelでデータ作成 ⇒ CSV出力 ⇒ 階層構造のJSONファイルへ変換出力と言ったステップでJSONファイルを作成して見ましたので紹介致します。 2.階層構造CSVtoJSONコンバータ 最初は、テキストエディタで手作業でJSONファイルを作成しょうと試みましたが、{}の対応付けや[,などの挿入漏れなど ミスすることが多くてデータを読み込むとエラーで動かないことの連続でした。何とか効率良く元データより階層構造の JSON形式のファイルを作成することができないものかとネット検索しても意図したものを見つけ出すことが出来ませんでした。 そこで今回、試行錯誤してExcel VBAで作成した 「階層構造CSVtoJSONコンバータ」 によるデータ作成手順をまとめて見ました。 階層構造のJSONファイルとは、 親、子、孫、曾孫・・・といった 階層構造のデータ形式のァイル です。 2-1.データの収集について まずは、目的とすべき元となるデータを収集しなければなりません。データの入手や収集手段はいろいろあると思いますが、 1回限りでのみ利用する場合や不定期、日次、週次、月次など継続的に利用する場合に応じて効率良い方法を選択する必要があります。 企業では自社内の各種システムにて収集や加工・編集などができるツール類もあると思いますが、個人ではなかなか揃えられません。 尚、今回は小規模なデータを扱うことを前提としているので効率的なデータの収集方法などについては別の機会にでも考えていきたいと 思います。ここでは、 「階層構造CSVtoJSONコンバータ」 の説明のためのテストデータを利用しての手順について説明します。 2-2.作成手順 (1)元データの準備 (テスト用に鳥類目録データの一部を利用) (2)Excelで元データを利用して、階層構造のデータ表を作成する。     ※【お願い】ファイルの終端判定のため、A列の末尾のセルにEOFと追記して下

HSPでコマンドプロンプトを制御する

-
イメージ
1.概要 最近は、Excel VBAやPythonなどによる自動化というキーワードを良く耳にしますが、昔からある自動化で最も安定性が あり、比較的単純な手順の記述とコマンド発行といったコマンドプロンプトによる操作およびバッチファイルによる自動処理 があります。システムの運用管理者やネットワーク管理者の人達も多く利用されています。 筆者も一時期は、良く利用していましたがGUIの操作に慣れ過ぎて最近は利用する機会も減ってきています。 今回は、HSP言語によるコマンドプロンプトを操作して外部から文字列(コマンド)を送信する方法を模索して見たいと思います。 2.コマンドプロンプトに文字列送信 コマンドプロンプトにGUI画面上からキー入力された文字列を送信する方法について説明します。 まず、概略の処理の流れを整理します。 (1) コマンドプロンプトを起動させる。 ただし、環境依存を無くすため環境変数 'comspec' より取得したパス名を、 exec 命令のp1パラメータとして渡す。 (2) 入力ボックス等より入力したコマンド（ テキスト文字列 ）をクリップボードにコピーする。 (3) コマンドプロンプト画面をアクティブにする。 (4) クリップボードよりコマンドを貼り付ける。 整理すると、これらの処理を実現させるためには、 ・環境変数'comspec'よりパス名を取得する処理 ・クリップボードにテキスト文字列をコピーする処理 ・任意の画面をアクティブにする処理 ・クリップボードよりテキスト文字列を貼り付ける処理 となります。ここで、一番難しいのはコンソールに対してクリップボードよりテキスト文字列を貼り付ける処理です。 [ ALT ]+[ SP ]+[ e ]+[ p ]+[ Enter ] キーという操作を keybd_event APIを 利用 して送り、貼り付け処理をしても良いのですが、メニューの操作をエミュレートするので、 [ ALT ]+[ SP ] で メニュー がポップアップし、次に [ e ] で編集がクリックされ、更に [ p ]+[ Enter ] キーといった流れとなって メニューの 操作が丸見えとなります。もちろん、動作的にも遅くスマートではありません。 コマンド

TOP