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

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

1 テーブルのソート順位に注意
2 生年階級のオブジェクトテーマカラー
3 コード
4 結果
5 共有:
6 関連

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

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

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

　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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

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

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 年以降続いている長期的なトレンドだ．

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

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

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

コード

結果

共有:

関連

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル