Excelのワークシートをマクロで集計して表とグラフを生成する

Excelで提供される自治体のデータは情報量が多く有益なのだが、一目でわかる形に加工することでより利用しやすいものになると考えマクロをつくってみた。

利用したExcelファイルは千葉県が提供する「新型コロナウイルス感染症患者等の県内発生状況について」である。
参考：千葉県庁ホームページ「患者の発生について｜新型コロナウイルス感染症」の「新型コロナウイルス感染症患者等の県内発生状況について」（日々更新）
＊2022/2/9からファイル名、フォーマットの一部、期間に変更あり。

すでに一行ずつ処理するタイプのマクロはつくってあったが処理スピードが遅いので今回はディクショナリを使用して処理速度をあげた。
参考：Excel VBA リファレンス

入出力フォーマット

入力ファイルは上のリンクの「[YYYYMMDD]kansensya.xlsx」、出力ファイルは「out.xlsx」と「out.pdf」である。
＊2022/2/9からファイル名は「[YYYYMMDD]kansensya2.xlsx」に変更。

入力ファイルのフォーマット

[No, 年代, 性別, 居住地, 区分, 発症日, 検査確定日]

図１．表

出力ファイルのフォーマット（PDFファイルはexcelファイルをエクスポートしたものなので省略。）

[日付, 10歳未満(男), 10歳未満(女), 10代(男), 10代(女), 20代(男), 20代(女), 30代(男), 30代(女), 40代(男), 40代(女), 50代(男), 50代(女), 60代(男), 60代(女), 70代(男), 70代(女), 80代(男), 80代(女), 90代以上(男), 90代以上(女), 小計(男), 小計(女), 合計]

図２．表

図３．グラフ

ざっくり解説

Main部分

Sub StartProcess()
    '前処理    
    '初期化
    Set gDicTable = CreateObject("Scripting.Dictionary") '集計用ディクショナリ
    Set gDicHokenjo = CreateObject("Scripting.Dictionary") '参照用ディクショナリ
    Call CreateDics

'保健所、市町村毎ループして辞書に集計、シート生成、出力
    Dim strKey As Variant, strVal As Variant, strSheetName As String
    For Each vstrKey In gDicHokenjo.keys()
        For Each vstrVal In gDicHokenjo(vstrKey)        
            Dim strHokenjo As String, strCity As String
            strHokenjo = vstrKey
            strCity = vstrVal
            strSheetName = strHokenjo & "_" & strCity '出力用ワークシート名
            
            '集計データ生成
            '①集計用ディクショナリに入力用ワークシートから読み込んだデータを入れる

            '集計データシート出力
            '②出力用ワークシートに集計用ディクショナリデータを出力する

            gDicTable.RemoveAll
        Next
    Next

    '後処理
    'もろもろ後始末
    '③excelブック、pdf出力
End Sub

参照用ディクショナリ（保健所毎）

Sub CreateDics()
    With gDicHokenjo
        .Add Key:="習志野", Item:=Array("習志野市", "八千代市", "鎌ケ谷市")
        .Add Key:="市川", Item:=Array("市川市", "浦安市")
        .Add Key:="松戸", Item:=Array("松戸市", "流山市", "我孫子市")
        .Add Key:="野田", Item:=Array("野田市")
        .Add Key:="印旛", Item:=Array("成田市", "佐倉市", "四街道市", "八街市", "印西市", "富里市", "酒々井町", "白井市", "栄町")
        .Add Key:="香取", Item:=Array("香取市", "神崎町", "多古町", "東庄町")
        .Add Key:="海匝", Item:=Array("銚子市", "旭市", "匝瑳市")
        .Add Key:="山武", Item:=Array("東金市", "山武市", "大網白里市", "九十九里町", "芝山町", "横芝光町")
        .Add Key:="長生", Item:=Array("茂原市", "一宮町", "睦沢町", "長生村", "白子町", "長柄町", "長南町")
        .Add Key:="夷隅", Item:=Array("勝浦市", "いすみ市", "大多喜町", "御宿町")
        .Add Key:="安房", Item:=Array("館山市", "南房総市", "鋸南町", "鴨川市")
        .Add Key:="君津", Item:=Array("木更津市", "君津市", "富津市", "袖ケ浦市")
        .Add Key:="市原", Item:=Array("市原市")
        .Add Key:="千葉市", Item:=Array("千葉市")
        .Add Key:="船橋市", Item:=Array("船橋市")
        .Add Key:="柏市", Item:=Array("柏市")
    End With
End Sub

①集計用ディクショナリに入力用ワークシートから読み込んだデータを入れる

集計したい市町村名を指定して「data（患者）」ワークシートの「居住地」を市町村名でフィルターする。
＊ここでは拡張性を持たせるために保健所に紐づいた市の配列を渡せるようにしている（AutoFilterのCriteria1には下のように配列が渡せる）が、このバージョンでは単一の市を渡している。（p_arrCity=Array(strCity)）

「tmp」ワークシートを用意しておきそこにフィルターしたデータをコピーする。
コピー後に「検査確定日」「居住地」でソートする。（居住地は配列で渡した場合のため）

    Set wsSource = wbBook.Worksheets("data（患者）")
    wsSource.Activate
    If wsSource.FilterMode Then wsSource.ShowAllData

    ActiveSheet.Range("B6").AutoFilter _
        field:=4, _
        Criteria1:=p_arrCity, _
        Operator:=xlFilterValues
    With ActiveSheet.Range("B6").CurrentRegion
        .Offset(3, 1).Resize(.Rows.Count - 1).Copy _
            Destination:=Sheets("tmp").Range("A1")
    End With
    With Sheets("tmp").Range("A1")
        .Sort key1:=.Range("G1"), order1:=xlAscending, key2:=.Range("D1"), order2:=xlAscending, Header:=xlYes
    End With

この「tmp」ワークシートからCountIfsを使用して日付毎に年代別性別に数値を集計する。

'数値を集計
iRetM = WorksheetFunction.CountIfs(Sheets("tmp").Columns("G"), dSearch, Sheets("tmp").Columns("B"), strNendai, Sheets("tmp").Columns("C"), "男性")
iRetW = WorksheetFunction.CountIfs(Sheets("tmp").Columns("G"), dSearch, Sheets("tmp").Columns("B"), strNendai, Sheets("tmp").Columns("C"), "女性")

指定市町村、指定期間のデータを一時ディクショナリで集計し、集計用ディクショナリgDicTableに追加していく。

gDicTable.Add Key:=dSearch, Item:=Array(dicNumber(gU10)(gM), dicNumber(gU10)(gW), dicNumber(gO10)(gM), dicNumber(gO10)(gW), _
            dicNumber(gO20)(gM), dicNumber(gO20)(gW), dicNumber(gO30)(gM), dicNumber(gO30)(gW), dicNumber(gO40)(gM), dicNumber(gO40)(gW), _
            dicNumber(gO50)(gM), dicNumber(gO50)(gW), dicNumber(gO60)(gM), dicNumber(gO60)(gW), dicNumber(gO70)(gM), dicNumber(gO70)(gW), _
            dicNumber(gO80)(gM), dicNumber(gO80)(gW), dicNumber(gO90)(gM), dicNumber(gO90)(gW), iSubTotalM, iSubTotalW, iTotal)

②出力用ワークシートに集計用ディクショナリデータを出力する

出力用ワークシートをアクティブにして１行目に項目名をセットして、集計用ディクショナリデータをTransposeを使用して出力する。
第１列にgDicTable.keys（日付）を、第２列以降にApplication.Transpose(gDicTable.Items)（「10歳未満(男)」から「合計」までのデータ）を出力する。

Sheets(p_strSheetName).Activate
With Range("A1:X1")
    .Value2 = Array("日付", "10歳未満(男)", "10歳未満(女)", "10代(男)", "10代(女)", "20代(男)", "20代(女)", "30代(男)", "30代(女)", "40代(男)", "40代(女)", "50代(男)", "50代(女)", "60代(男)", "60代(女)", "70代(男)", "70代(女)", "80代(男)", "80代(女)", "90代以上(男)", "90代以上(女)", "小計(男)", "小計(女)", "合計")
    .Font.Bold = True
End With
Cells(2, 1).Resize(gDicTable.Count, 1).Value2 = Application.Transpose(gDicTable.keys)
Cells(2, 2).Resize(gDicTable.Count, gNUM_COL_SIZE).Value2 = Application.Transpose(Application.Transpose(gDicTable.Items))

出力した表を使用してグラフを出力する。

With ActiveSheet.Shapes.AddChart2
    .Top = Cells(Cells(Rows.Count, 1).End(xlUp).Row + 2, 2).Top
    .Left = Cells(Cells(Rows.Count, 1).End(xlUp).Row + 2, 2).Left
    .Height = 400
    .Width = 600
    .Name = "Chart1"
    With .Chart
        '凡例
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom
        
        .ChartType = xlColumnStacked
        .SetSourceData ActiveSheet.Range("A1").CurrentRegion
        .HasTitle = True
        .ChartTitle.Text = strSheetName & " 新規感染者数"
        
        '系列
        .FullSeriesCollection(gNENDAI_SUBTOTAL_M).IsFiltered = True '"小計(男)"
        .FullSeriesCollection(gNENDAI_SUBTOTAL_M + 1).IsFiltered = True '"小計(女)"
        .FullSeriesCollection(gNENDAI_SUBTOTAL_M + 2).IsFiltered = True '"合計"
        
        .SeriesCollection(gU10_M).Format.Fill.ForeColor.RGB = RGB(204, 255, 255)
		'以下年代別性別分グラフの色指定

        '系列 合計をデータラベルにする
        With .SeriesCollection(gO90_W)
            .HasDataLabels = True
            For i = 1 To .Points.Count
                .Points(i).DataLabel.Text = gDicTable(gDicTable.keys()(i - 1))(gNENDAI_TOTAL - 1) 
                .Points(i).DataLabel.Top = .Points(i).Top - 20
            Next
        End With
    End With
End With

③excelブック、pdf出力

集計したシートを出力用ブック（"out.xlsx"）にコピーする。
コピーしたいワークシート名を配列に入れてまとめてコピーする。

Dim strFileName As String: strFileName = "out.xlsx"
Dim strPathName As String, strFullPath As String
strPathName = ThisWorkbook.Path
strFullPath = strPathName & "\" & strFileName

Workbooks.Add
ActiveWorkbook.SaveAs strFullPath

Dim varrSheetName()
Dim n
For Each ws In ThisWorkbook.Worksheets
    n = n + 1
    ReDim Preserve varrSheetName(1 To n)
    varrSheetName(n) = ws.Name
Next ws

ThisWorkbook.Sheets(varrSheetName).Copy After:=Workbooks(strFileName).Sheets(1)
Application.DisplayAlerts = False
Workbooks(strFileName).Sheets(1).Delete
Application.DisplayAlerts = True

出力したブックの内容をPDFファイルにエクスポートする。

Dim strFileName As String: strFileName = "out.xlsx"
Workbooks(strFileName).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\out.pdf", Quality:=xlQualityStandard, OpenAfterPublish:=True, IncludeDocProperties:=False

注意

実際のコードは細かい調整処理をしていて長いため部分的に抜き出して掲載した。そのためこのままでは動作しない場合もあるので参考程度にご覧いただきたい。

追記

今回のようにワークシートが多い場合以下のようなワークシートリストをポップアップ表示するマクロを追加してオプションからキーボードショートカットを設定すると楽。

Sub shortcut4popup_sheetmenu()
    Application.CommandBars("Workbook tabs").Controls("シートの選択...").Execute  '.ShowPopup
End Sub