国勢調査から男女別の５歳階級の人口推移を積み上げ横棒グラフに描く

　前回の記事では大正 9 年から平成 17 年までの日本人口総数の年齢階級推移を積み上げ縦棒グラフに描いた．今回は男女別に描く．

テーブルのソート順位に注意

　テーブルは前回同様であるが，年度を降順ソートするところが違う．まず年度を降順ソート，ついで生年を降順ソートである．

生年階級のオブジェクトテーマカラー

　5 歳階級を 5 系統ごと，つまり 25 年ごとに 1 系統のテーマカラーを割り当てる．詳細はEXCEL VBA から見たオブジェクトテーマカラーと RGB の変換を参照されたい．

コード

Option Explicit

Sub MaleFemaleChart()

Dim mySht1      As Worksheet
Dim mySht2      As Worksheet
Dim myLstObj    As ListObject
Dim myCht1      As Chart
Dim myCht2      As Chart

Set mySht1 = Worksheets("Sheet3")
Set myLstObj = mySht1.ListObjects(1)
Set mySht2 = Worksheets.Add(after:=mySht1)
Set myCht1 = mySht2.Shapes.AddChart2(Style:=-1, _
                              XlChartType:=xlBarStacked, _
                                     Left:=0, _
                                      Top:=0, _
                                    Width:=400, _
                                   Height:=400).Chart
Set myCht2 = mySht2.Shapes.AddChart2(Style:=-1, _
                               XlChartType:=xlBarStacked, _
                                      Left:=400, _
                                       Top:=0, _
                                     Width:=400, _
                                    Height:=400).Chart

Dim i           As Long
Dim j           As Long
Dim myRng       As Range

Dim FiscalYear()    As Long
Dim Male()          As Long
Dim Female()        As Long

Dim mySeries1       As Series
Dim mySeries2       As Series

For i = 2005 To 1835 Step -5
    With myLstObj
        .Range.AutoFilter field:=1, Criteria1:=i
        Set myRng = Intersect(.DataBodyRange, _
                               .Range.SpecialCells(Type:=xlCellTypeVisible))
        If myRng Is Nothing Then
        Else
            For j = 0 To myRng.Rows.Count - 1
                ReDim Preserve FiscalYear(j)
                ReDim Preserve Male(j)
                ReDim Preserve Female(j)
                FiscalYear(j) = myRng.Cells(j + 1, 2)
                Male(j) = myRng.Cells(j + 1, 4)
                Female(j) = myRng.Cells(j + 1, 5)
            Next j
            Set mySeries1 = myCht1.SeriesCollection.NewSeries
            Set mySeries2 = myCht2.SeriesCollection.NewSeries
            With mySeries1
                .Name = i
                .XValues = FiscalYear
                .Values = Male
            End With
            With mySeries2
                .Name = i
                .XValues = FiscalYear
                .Values = Female
            End With
        End If
        .Range.AutoFilter field:=1
    End With
Next i

Dim myChtObj    As ChartObject
Dim myAxis      As Axis
Dim myChtGrp    As ChartGroup

'Debug.Print TypeName(mySht2.ChartObjects)
For Each myChtObj In mySht2.ChartObjects
    'Debug.Print myChtObj.Parent.Index
    Set myCht1 = myChtObj.Chart
    'Debug.Print myCht1.Name
    With myCht1
        .HasTitle = True
        With .ChartTitle
            If myCht1.Name = "Sheet3 グラフ 1" Then
                .Caption = "男性人口の年齢階級推移"
                .Left = 0
            Else
                .Caption = "女性人口の年齢階級推移"
                .Left = 240
            End If
        End With
        Set myAxis = .Axes(xlCategory)
        With myAxis
            .Format.Line.Visible = msoFalse
            .MajorGridlines.Format.Line.Visible = msoFalse
        End With
        Set myAxis = .Axes(xlValue)
        With myAxis
            If myCht1.Name = "Sheet3 グラフ 1" Then
                .ReversePlotOrder = True
            End If
            .DisplayUnit = xlTenThousands
            .Format.Line.Visible = msoFalse
            .MaximumScale = 75000000
            .MajorUnit = .MaximumScale / 3
            .MajorGridlines.Format.Line.Visible = msoFalse
            With .DisplayUnitLabel
                .Delete
            End With
        End With
        With .PlotArea
            .Format.Fill.Visible = msoFalse
            .Format.Line.Visible = msoFalse
            .Left = -10
            .Width = 400
            .Top = 30
            .Height = 380
        End With
        With .ChartArea
            .Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
            .Format.TextFrame2.TextRange.Font.Name = "TimesNewRoman"
        End With
        Set myChtGrp = .ChartGroups(1)
        With myChtGrp
            .GapWidth = 0
        End With
        For Each mySeries1 In .SeriesCollection
            With mySeries1
                'Debug.Print .Format.Fill.ForeColor.RGB
                Select Case .Name
                Case "2020"
                .Format.Fill.ForeColor.RGB = RGB(218, 227, 243)
                Case "2015"
                .Format.Fill.ForeColor.RGB = RGB(180, 199, 231)
                Case "2010"
                .Format.Fill.ForeColor.RGB = RGB(143, 170, 220)
                Case "2005"
                .Format.Fill.ForeColor.RGB = RGB(47, 85, 151)
                Case "2000"
                .Format.Fill.ForeColor.RGB = RGB(32, 56, 100)
                Case "1995"
                .Format.Fill.ForeColor.RGB = RGB(226, 240, 217)
                Case "1990"
                .Format.Fill.ForeColor.RGB = RGB(197, 224, 180)
                Case "1985"
                .Format.Fill.ForeColor.RGB = RGB(169, 209, 142)
                Case "1980"
                .Format.Fill.ForeColor.RGB = RGB(84, 130, 53)
                Case "1975"
                .Format.Fill.ForeColor.RGB = RGB(56, 87, 35)
                Case "1970"
                .Format.Fill.ForeColor.RGB = RGB(255, 242, 204)
                Case "1965"
                .Format.Fill.ForeColor.RGB = RGB(255, 230, 153)
                Case "1960"
                .Format.Fill.ForeColor.RGB = RGB(255, 217, 102)
                Case "1955"
                .Format.Fill.ForeColor.RGB = RGB(191, 144, 0)
                Case "1950"
                .Format.Fill.ForeColor.RGB = RGB(127, 96, 0)
                Case "1945"
                .Format.Fill.ForeColor.RGB = RGB(251, 229, 214)
                Case "1940"
                .Format.Fill.ForeColor.RGB = RGB(248, 203, 173)
                Case "1935"
                .Format.Fill.ForeColor.RGB = RGB(244, 177, 131)
                Case "1930"
                .Format.Fill.ForeColor.RGB = RGB(197, 90, 17)
                Case "1925"
                .Format.Fill.ForeColor.RGB = RGB(132, 60, 12)
                Case "1920"
                .Format.Fill.ForeColor.RGB = RGB(242, 242, 242)
                Case "1915"
                .Format.Fill.ForeColor.RGB = RGB(217, 217, 217)
                Case "1910"
                .Format.Fill.ForeColor.RGB = RGB(191, 191, 191)
                Case "1905"
                .Format.Fill.ForeColor.RGB = RGB(166, 166, 166)
                Case "1900"
                .Format.Fill.ForeColor.RGB = RGB(127, 127, 127)
                Case "1895"
                .Format.Fill.ForeColor.RGB = RGB(242, 242, 242)
                Case "1890"
                .Format.Fill.ForeColor.RGB = RGB(217, 217, 217)
                Case "1885"
                .Format.Fill.ForeColor.RGB = RGB(191, 191, 191)
                Case "1880"
                .Format.Fill.ForeColor.RGB = RGB(166, 166, 166)
                Case "1875"
                .Format.Fill.ForeColor.RGB = RGB(127, 127, 127)
                Case "1870"
                .Format.Fill.ForeColor.RGB = RGB(242, 242, 242)
                Case "1865"
                .Format.Fill.ForeColor.RGB = RGB(217, 217, 217)
                Case "1860"
                .Format.Fill.ForeColor.RGB = RGB(191, 191, 191)
                Case "1855"
                .Format.Fill.ForeColor.RGB = RGB(166, 166, 166)
                Case "1850"
                .Format.Fill.ForeColor.RGB = RGB(127, 127, 127)
                Case "1845"
                .Format.Fill.ForeColor.RGB = RGB(242, 242, 242)
                Case "1840"
                .Format.Fill.ForeColor.RGB = RGB(217, 217, 217)
                Case "1835"
                .Format.Fill.ForeColor.RGB = RGB(191, 191, 191)
                End Select
            End With
        Next mySeries1
    End With
Next myChtObj
End Sub

結果

　男女別にすることで見えてくるものもある．1975 年以降，一貫して少子化が進行している．女性の方が長生きする．日本は「おばあちゃん大国」になる．

　少子化の原因は女性が生む子供の数が減ったからではない．母親となりうる年齢の女性が減ったためである．そして，いったん負のスパイラルに陥った人口減少は複利効果で指数関数的に減少していく．それが 1975 年以降続いている長期的なトレンドだ．

　少子化対策は必要だ．しかし，それと今後の予測，つまり確実にやってくる未来とは切り離して受け止める必要がある．