過去に取得済み月単位気象データを年単位に統合

1.概要

当ブログの「過去の気象データ検索からのデータ取得」で気象庁のページより取得済みのデータが溜まっていますので、 今回は、この溜まったデータの整理方法について紹介します。年単位のフォルダに保存している月単位(1月から12月)のブックを1つのブックに統合します。 月別のデータを12枚のシートと年毎に集約した気温データ一覧、気温グラフ一覧、気圧グラフ一覧、湿度グラフ一覧、風速グラフ一覧、日照時間グラフ一覧、降水量グラフ一覧を 加えた計19枚のシートを作成して纏めるものです。

2.使用方法

(1)気象庁_気象データ統合.xlsmを起動します。
(2)カレントディレクトリに作業用サブフォルダのWORKディレクリを作成し、月別ファイルを
     コピーします。※作業用のWORKフォルダは必ず作成して下さい。

(3)気象データブック統合処理ボタンをクリックします。
(4)作業用フォルダのWORK内のファイル一覧を取得して、ファイル統合処理を開始します。
(5)統合処理が完了すると、WORK内のコピー元ファイルの削除応答があるので、OKボタンを
     クリックします。※特別な用途がなければ、通常は削除して下さい。

(6)グラフ作成処理と統合ファイルの作成が全て完了したら、ダイアログのOKボタンを
     クリックして処理を終了します。

(7)統合されたファイルは、カレントディレクリに〇〇〇〇年気象情報.xlsxという形式
     で出力されるので、月別の管理フォルダと同様に気象年別統計データというフォルダを作成して
     管理すると良いと思います。

尚、作成されるシート名は、以下の通りです。(例：2020年の場合)
・2020年1月～2020年12月 (計12シート)
・気温データ一覧
・気温グラフ一覧
・気圧グラフ一覧
・湿度グラフ一覧
・日照時間グラフ一覧
・風速グラフ一覧
・降水量グラフ一覧

3.ソースコード

ソースコードは、下記の通りです。Sheet1(ブック統合処理)は、シート上に配置した 「気象データブック統合処理」ボタンのクリックイベントです。クリックすると、標準モジュールのBookcomの CopyBook()の処理を実行します。 事前に作成してあるWORKフォルダ内にコピーしてある1月から12月までのブックファイルのファイル名一覧を取得してシート上に取得ファイル名一覧として 表示します。一旦、新規に作業用の一時ファイル(sample.xlsx)を作成してコピー先に設定し、フォルダ内のExcelブックを検索します。 続いて、1月から12月のフォルダ内のブックファイルをコピー先のsample.xlsxにコピーします。 不要な空きシートを削除します。これで、取りあえず、1月から12月までの月別のブックファイルが作業用のsample.xlsxにシート分けされてコピーされます。 コピー展開された各月別のシートには、気温データやグラフ類がありますので、これらのグラフ類を月別、種類別に纏めるため、12月分のシートの次のシートから グラフの集約処理を実施しています。処理が終了したら、ブック形式で名前を付けて保存後、WORKフォルダ内のデータを削除するかのダイアログを表示して OKをクリックすると、WORKフォルダ内のデータを削除して終了します。
保存したブックは、カレントディレクリにxxxx年気象情報.xlsxとして格納されていますので、管理フォルダに移動して管理するようにします。

Private Sub MulutiCopy_Click()
   Call CopyBook
End Sub

***********************************************************************
' *     気象庁_気象データ統合.xlsm Ver3.0
' *
' *
' *　●気象庁_気象情報データの複数ブックファイルを1つにまとめる処理
' *
' *  新規にコピー用のワークブック(sample.xlsx)を作成して
' *  作業用のディレクトリに格納されている複数のブックファイル
' *  1つずつ取得してまとめる。
' *  シートを追加して気温のデータシートと気温グラフを1年分作成
' *  する。また、気温以外の気圧、湿度、日照時間、風速、降水量
' *  のグラフをシートを追加して、それぞれを１年分まとめる。
' *
' *
' *  初版 Ver1.0 2012.4.19 Excel2007で作成
' *  改訂 Ver2.0 2013.8.27
' *  改訂 Ver3.0 2018.3.15 Excel2016に対応
' *
' *
' ***********************************************************************

Option Explicit

Sub CopyBook()
   Dim mb           As Workbook
   Dim wb           As Workbook
   Dim myfdr        As String
   Dim fname        As String
   Dim WorkFileName As String
   Dim n            As Integer

   '***** コピー対象ファイル名一覧表の取得 *****
   Dim Tempdir      As String
   Dim Tempfname    As String
   Dim ft           As String
   Dim j            As Integer

   On Error Resume Next

   Workbooks("気象庁_気象データ統合.xlsm").Activate
   Tempdir = ThisWorkbook.Path & "¥work"
   
   '***** カレントディレクトリよりファイル名一覧を取得 *****
   Tempfname = Dir(Tempdir & "¥*.xlsx")

   '***** シート内のファイル名一覧を消去 *****
   Range("E5") = ""
   If Range("C6") <> "" Then
      Range("C6:C100").SpecialCells(xlCellTypeConstants, 23).ClearContents
   End If
   
   '***** 最初の一件を表示 *****
   ft = Tempfname
   Range("C6") = ft
   
   j = 0
   Do While ft <> ""
      j = j + 1
      ft = Dir()
      Range("C6").Offset(j, 0) = ft
   Loop
   '***** 並べ替え (降順) *****
   Range("C6:C20").Sort _
        Key1:=Range("C6") _
        , Order1:=xlAscending _
        , Header:=xlGuess _
        , MatchCase:=False _
        , Orientation:=xlTopToBottom _
        , SortMethod:=xlPinYin
        
   '***** 取得件数 *****
   Range("E5") = j

   '***** コピー対象ファイルが登録されていない場合 *****
   If j = 0 Then
      MsgBox "コピーするファイルが登録されていません。処理を終了します。"
      Exit Sub
   End If

   '***** コピー用の新規ブックを作成 *****
   Workbooks.Add                 ' 新規ブックを追加
   ' ブック形式で名前を付けて自動保存 (for Excel2007以降形式)
   Dim Outbook As Workbook
   Set Outbook = ActiveWorkbook
   Outbook.SaveAs FileName:=ThisWorkbook.Path & "¥sample.xlsx"
   '***** ブックを閉じる *****
   ActiveWorkbook.Close
   WorkFileName = ThisWorkbook.Path & "¥sample.xlsx"

   Application.ScreenUpdating = False      ' 画面更新を一時停止

   '***** 新規に作成した作業用の一時ファイルをコピー先に設定 *****
   Set mb = Workbooks.Open(WorkFileName)
   
   myfdr = ThisWorkbook.Path & "¥work"
   fname = Dir(myfdr & "¥*.xlsx", vbNormal) 'フォルダ内のExcelブックを検索

   Dim kensuu   As Integer
   Dim fn       As String
   Dim c        As Object
   Dim DelSheet As Object
   
   ' コピー対象ファイル数を取得 (最初の1件目はカウントされないので、kensuuに+1しておく)
   fn = fname
   Do While fn <> ""
      kensuu = kensuu + 1
      fn = Dir()
   Loop
   
   ' ファルダ内のコピーファイル件数
   kensuu = kensuu - 1
 
   '***** 1月から12月のフォルダ内のブックファイルをコピー先のsample.xlsxにコピー *****
   
   fname = Dir(myfdr & "¥*.xlsx")  ' フォルダ内のExcelブックを検索
   Do Until fname = Empty          ' 全て検索
      If fname <> mb.Name Then     ' ブック名がこのブックの名前でなければ
         Set wb = Workbooks.Open(myfdr & "¥" & fname)          ' そのブックを開きwbとする。
         wb.ActiveSheet.Copy after:=mb.Sheets(mb.Sheets.Count) ' 開いたシートをコピーしてmbの末尾に置く
         wb.Close (False) '有無を言わずに保存せず閉じる

         For Each c In mb.Sheets(mb.Sheets.Count).UsedRange    ' 取り込んだシートの使用範囲に
             If c.FormulaR1C1 Like "=*!*" Then                 ' 他シート参照があれば
                c.Value = c.Value                              ' 値に変更
             End If
         Next
         
         '***** Excel2016対策 (デフォルトのフォントで影響を受けるのを防止) *****
         Call CellFontSet
         
         n = n + 1 'ブック数をカウント
      End If
      fname = Dir()  ' フォルダ内の次のExcelブックを検索
      DoEvents
   Loop

   '***** 不要なSheet1～Sheet3を削除する *****
   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
   

   Dim TopSheetName As String
   Dim nTMoove      As String
   
   TopSheetName = Left(Sheets(1).Name, 5)
   
   ' ************************************************************************
   ' NTFSの場合とFAT32のフォーマットによりシート位置がずれる
   ' NTFSの場合は、ファイル名の順番
   ' FAT32の場合は、ディスクに保存された順番
   ' ************************************************************************
   
   If Mid(Sheets(1).Name, 6, 2) <> "1月" Then
   ' 先頭のシートを末尾に移動 (ファイルフォーマットによって変わるため)
      nTMoove = Sheets(1).Name
      Sheets(1).Move before:=Sheets(Sheets.Count)
      Sheets(nTMoove).Move after:=Sheets(Sheets.Count)
   End If


   '●●●●● 気温データの集約シートの作成 ●●●●●
   ' 作業用一時ファイルに展開された各シートから気温データのみ取り出し
   ' 作業用シートの末尾にコピーする。(集約する)
   Dim w As Integer, z As Integer
   Dim nSheetPos       As Variant
   Dim nHeadPos        As Variant
   Dim GraphName       As String
    
   '***** データシート貼付位置 *****
   nSheetPos = Array("A2", "F2", "K2", "P2", "U2", "Z2", "A39", "F39", "K39", "P39", "U39", "Z39")
   nHeadPos = Array("A1", "F1", "K1", "P1", "U1", "Z1", "A38", "F38", "K38", "P38", "U38", "Z38")
    
   w = Workbooks("sample.xlsx").Worksheets.Count

   Sheets.Add after:=Sheets(Sheets.Count)
   Sheets(w + 1).Select
   Sheets(w + 1).Name = "気温データ一覧"
    
   '***** 基本データ (日付、曜日、平均、最高、最低気温データ) *****
   For z = 1 To w
      Sheets(z).Select
      Range("A2:B36,H2:J36").Select
      Selection.Copy
      Sheets("気温データ一覧").Select
      Range(nSheetPos(z - 1)).Select
      ActiveSheet.Paste
      Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
          SkipBlanks:=False, Transpose:=False
      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=False
   Next
   '■ヘッド名 (月名)
   For z = 1 To w
      Sheets(z).Select
      Range("A1").Select
      Selection.Copy
      Sheets("気温データ一覧").Select
      Range(nHeadPos(z - 1)).Select
      ActiveSheet.Paste
      Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=False
   Next
   ActiveWindow.DisplayGridlines = False
   
   'Application.WindowState = xlMinimized

   ' ▼▼▼▼▼▼▼　グラフの集約　▼▼▼▼▼▼▼

   ' ***** グラフ関連の貼付位置 (全グラフ共通) *****
   nSheetPos = Array("A2", "A26", "A50", "A74", "A98", "A122", "A146", "A170", "A194", "A218", "A242", "A266")
   nHeadPos = Array("F24", "F48", "F72", "F96", "F120", "F144", "F168", "F192", "F216", "F240", "F264", "F288")
    
   w = Workbooks("sample.xlsx").Worksheets.Count

   Sheets.Add after:=Sheets(Sheets.Count)
   Sheets(w + 1).Select
   Sheets(w + 1).Name = "気温グラフ一覧"
    
   ' ***** 気温グラフ *****
   For z = 1 To w - 1
      Sheets(z).Select
      Sheets(z).Activate
      ActiveSheet.ChartObjects(1).Activate
      ActiveChart.ChartArea.Copy
      Sheets("気温グラフ一覧").Select
      Range(nSheetPos(z - 1)).Select
      ActiveSheet.Paste
   Next
        
   '■気温タイトル名
   For z = 1 To w - 1
      Sheets(z).Select
      Sheets(z).Activate
      Range("A1").Select
      GraphName = Range("A1")
      GraphName = GraphName & "気温の推移(平均､最高､最低)"
      Sheets("気温グラフ一覧").Select
      Range(nHeadPos(z - 1)).Select
      Range(nHeadPos(z - 1)) = GraphName
       
      '■気温グラフタイトルのフォント変更
      Call TitlefontSet
   Next

   w = Workbooks("sample.xlsx").Worksheets.Count

   Sheets.Add after:=Sheets(Sheets.Count)
   Sheets(w + 1).Select
   Sheets(w + 1).Name = "気圧グラフ一覧"
    
   ' ***** 気圧グラフ *****
   For z = 1 To w - 2
      Sheets(z).Select
      Sheets(z).Activate
      ActiveSheet.ChartObjects(2).Activate
      ActiveChart.ChartArea.Copy
      Sheets("気圧グラフ一覧").Select
      Range(nSheetPos(z - 1)).Select
      ActiveSheet.Paste
   Next
        
   '■気圧タイトル名
   For z = 1 To w - 2
      Sheets(z).Select
      Sheets(z).Activate
      Range("A1").Select
      GraphName = Range("A1")
      GraphName = GraphName & "気圧の推移(現地、海面)"
      Sheets("気圧グラフ一覧").Select
      Range(nHeadPos(z - 1)).Select
      Range(nHeadPos(z - 1)) = GraphName
       
      '■気圧グラフタイトルのフォント変更
      Call TitlefontSet
   Next
    
   w = Workbooks("sample.xlsx").Worksheets.Count

   Sheets.Add after:=Sheets(Sheets.Count)
   Sheets(w + 1).Select
   Sheets(w + 1).Name = "湿度グラフ一覧"
    
   ' ***** 湿度グラフ *****
   For z = 1 To w - 3
      Sheets(z).Select
      Sheets(z).Activate
      ActiveSheet.ChartObjects(3).Activate
      ActiveChart.ChartArea.Copy
      Sheets("湿度グラフ一覧").Select
      Range(nSheetPos(z - 1)).Select
      ActiveSheet.Paste
   Next
        
   '■湿度タイトル名
   For z = 1 To w - 3
      Sheets(z).Select
      Sheets(z).Activate
      Range("A1").Select
      GraphName = Range("A1")
      GraphName = GraphName & "湿度の推移(平均、最小)"
      Sheets("湿度グラフ一覧").Select
      Range(nHeadPos(z - 1)).Select
      Range(nHeadPos(z - 1)) = GraphName
       
      '■湿度グラフタイトルのフォント変更
      Call TitlefontSet
   Next
 
   w = Workbooks("sample.xlsx").Worksheets.Count

   Sheets.Add after:=Sheets(Sheets.Count)
   Sheets(w + 1).Select
   Sheets(w + 1).Name = "日照時間グラフ一覧"
    
   ' ***** 日照時間グラフ *****
   For z = 1 To w - 4
      Sheets(z).Select
      Sheets(z).Activate
      ActiveSheet.ChartObjects(4).Activate
      ActiveChart.ChartArea.Copy
      Sheets("日照時間グラフ一覧").Select
      Range(nSheetPos(z - 1)).Select
      ActiveSheet.Paste
   Next
        
   '■日照時間タイトル名
   For z = 1 To w - 4
      Sheets(z).Select
      Sheets(z).Activate
      Range("A1").Select
      GraphName = Range("A1")
      GraphName = GraphName & "日照時間の推移"
      Sheets("日照時間グラフ一覧").Select
      Range(nHeadPos(z - 1)).Select
      Range(nHeadPos(z - 1)) = GraphName
       
      '■日照時間グラフタイトルのフォント変更
      Call TitlefontSet
   Next

   w = Workbooks("sample.xlsx").Worksheets.Count

   Sheets.Add after:=Sheets(Sheets.Count)
   Sheets(w + 1).Select
   Sheets(w + 1).Name = "風速グラフ一覧"
    
   ' ***** 風速グラフ *****
   For z = 1 To w - 5
      Sheets(z).Select
      Sheets(z).Activate
      ActiveSheet.ChartObjects(5).Activate
      ActiveChart.ChartArea.Copy
      Sheets("風速グラフ一覧").Select
      Range(nSheetPos(z - 1)).Select
      ActiveSheet.Paste
   Next
        
   '■風速タイトル名
   For z = 1 To w - 5
      Sheets(z).Select
      Sheets(z).Activate
      Range("A1").Select
      GraphName = Range("A1")
      GraphName = GraphName & "風速(平均、最大)の推移"
      Sheets("風速グラフ一覧").Select
      Range(nHeadPos(z - 1)).Select
      Range(nHeadPos(z - 1)) = GraphName
       
      '■風速グラフタイトルのフォント変更
      Call TitlefontSet
    Next

    w = Workbooks("sample.xlsx").Worksheets.Count

    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(w + 1).Select
    Sheets(w + 1).Name = "降水量グラフ一覧"
    
   ' ***** 降水量グラフ *****
   For z = 1 To w - 6
      Sheets(z).Select
      Sheets(z).Activate
      ActiveSheet.ChartObjects(6).Activate
      ActiveChart.ChartArea.Copy
      Sheets("降水量グラフ一覧").Select
      Range(nSheetPos(z - 1)).Select
      ActiveSheet.Paste
   Next
        
   '■降水量タイトル名
   For z = 1 To w - 6
      Sheets(z).Select
      Sheets(z).Activate
      Range("A1").Select
      GraphName = Range("A1")
      GraphName = GraphName & "降水量(合計、１時間、10分間)の推移"
      Sheets("降水量グラフ一覧").Select
      Range(nHeadPos(z - 1)).Select
      Range(nHeadPos(z - 1)) = GraphName
       
      '■降水量グラフタイトルのフォント変更
      Call TitlefontSet
   Next

   Sheets(1).Select

   Application.ScreenUpdating = True  ' 画面更新一時停止を解除
    
   '▼▼▼▼▼ 後処理 ▼▼▼▼▼

   '***** ブック形式で名前を付けて自動保存 *****
   Dim Savebook As Workbook
   Dim NewName  As String
   Dim rc       As VbMsgBoxResult
   
   Set Savebook = ActiveWorkbook

   '***** 格納ファイル名 *****
   NewName = "¥" & TopSheetName & "気象情報.xlsx"
   Savebook.SaveAs FileName:=ThisWorkbook.Path & NewName
  '***** ブックを閉じる *****
   ActiveWorkbook.Close

   '***** 一時作成した sample.xlsx を削除する *****
   Kill ThisWorkbook.Path & "¥sample.xlsx"

   '***** 確認メッセージを非表示にする *****
   Application.DisplayAlerts = True

   '***** コピー元ファイルの削除確認 *****
   rc = MsgBox("¥WORKのコピー元ファイルを削除しますか？", vbYesNo + vbQuestion)
   If rc = vbYes Then
      Kill ThisWorkbook.Path & "¥WORK¥*.xlsx"
   End If


   '***** マクロ画面に戻る *****
   Workbooks("気象庁_気象データ統合.xlsm").Activate

   MsgBox n & "件のブックをコピーしましました。"

   '***** ファイル名一覧を消去 *****
   Range("E5") = ""
   If Range("C6") <> "" Then
      Range("C6:C100").SpecialCells(xlCellTypeConstants, 23).ClearContents
   End If
   Range("A1").Select
End Sub

'***** 各グラフのタイトルフォント設定 *****
Sub TitlefontSet()
    With Selection
         .Font.Size = 11
         .Font.Bold = True
         .Font.Name = "ＭＳ Ｐゴシック"
    End With
    ActiveWindow.DisplayGridlines = False
End Sub

'***** 表の体裁統一のため *****
Sub CellFontSet()
    Cells.Select
    With Selection.Font
        .Name = "ＭＳ Ｐゴシック"
        .Size = 10
    End With
       
    Rows("1:1").Select
    Selection.RowHeight = 22.5
    Rows("2:300").Select
    Selection.RowHeight = 13.5
    Range("A2").Select
End Sub

4.ダウンロード

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

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

ダウンロード

■関連記事
・過去の気象データ検索からのデータ取得