（Ver.3）修学支援新制度のためGPA分布表作成マクロを改変しました。

文科省Q&A更新の影響

高等教育段階の教育費負担新制度に係る質問と回答（Q＆A）：文部科学省

Q101
ＧＰA等の客観的指標が、学部等で下位4分の1との基準について、同順位に複数名がいる場合は、「下位4分の1」にどの範囲まで含まれるのでしょうか。

A101
下位4分の1のライン上に複数の者が並んでいる場合、これらの者は上位4分の3にも属していることになるため、当該者は「下位4分の1」として「警告」の対象となりません。
例えば、12人の課程（下位4分の1は3人）に、上位7番目の者が4人いるような場合には、下位3人目の成績に相当する者が4人いますが、この場合には、当該4人は警告の対象とはせず、下位2人を警告の対象とすることになります。

　修学支援新制度に係るQ&Aが更新され、適格認定に用いるGPA下位25%以下の基準の取り扱いが新たに明記されました。実は、この取り扱いは先日弊BLOGで公表したGPA分布表作成マクロVer2とは異なります。Ver2では下位25%以下の者の人数を累積頻度0.25以下の個数の合計としていました。しかし、文科省の見解では、ライン上に複数名が存在している場合は全員を警告ラインから除外するとしています。これは、下図の通り整理できます。

　これについて、一晩かけて対応を検討し、GPA分布表作成マクロVer.3を作成しました。

GPA分布表作成マクロVer.3

警告ラインの考え方

警告ラインについて、下記表のとおり整理できます。

警告ラインに存在する人数		累積頻度0.25の値の個数
		0個	1個	複数個
累積頻度0.25未満の最大値の個数	1個	累積頻度0.25未満の個数	累積頻度0.25未満の個数	累積頻度0.25未満の個数
	複数個	累積頻度0.25未満の個数-累積頻度0.25未満の最大値の個数	累積頻度0.25未満の個数	累積頻度0.25未満の個数

　文科省の言う「下位4分の1のライン上に複数の者が並んでいる場合」とは、図のとおり、累積頻度0.25の値が存在しない場合に累積頻度0.25未満の最大値が複数ある場合と整理しました。

　これに基づき、警告ラインに存在する人数の算出は以下のとおり整理できます。

• 累積頻度0.25が存在する場合
  • 累積頻度0.25未満の個数
• 累積頻度0.25が存在しない場合
  • 累積頻度0.25未満の最大値が1個存在する場合
    • 累積頻度0.25未満の個数
  • 累積頻度0.25未満の最大値が複数個存在する場合
    • 累積頻度0.25未満の個数から累積頻度0.25未満の最大値の個数を除外

　この条件式をコードに反映させました。

今回の見解に関する所感

　「下位4分の1のライン上に複数の者が並んでいる場合、（略）当該者は「下位4分の1」として「警告」の対象となりません。」とした今回の見解は、基準を緩め少しでも多くの者を救おうとする文科省の意思が感じられるものだと認識しています。

　また、下位4分の1を抽出しようとすると、どのように考えるべきか迷う場面もありました（実際、累積頻度0.25の者の取り扱いはあまり自信がありません）。下手したら訴訟沙汰になるなと感じています。特に境界付近の者の取り扱いや判断には慎重にならなければなりませんね。

機能の追加

　ついでなので、以下の通り、新たに機能を追加しました。

1. 下位４分の１の人数がわかる表を作成（前述）
2. 累積頻度0.25前後の者がわかる表を作成
3. 「本シート以外印刷」機能
4. 「本シート以外印刷（氏名非表示）」機能

※上記図中のGPA及び氏名は乱数により発生された数値及び文字列です。

累積頻度0.25前後の者がわかる表を作成

　実際にGPAを用いて警告者を確認する際には、GPA値だけではなくそれが誰なのかが必要になります。そのため、Sheet1のF列に新たに氏名欄を設け、ヒストグラム作成の際に併せて作成される0.23-0.27の頻度表に氏名を列記するようにしました。

　なお、氏名欄に何も入力しない場合は、0.23-0.27の頻度表に氏名欄は発生しません。

「本シート以外印刷」機能

　同マクロを使用する手順を

1. GPAの入力
2. ヒストグラムの作成
3. 別の学部等のGPAの入力
4. 新たなシートにヒストグラムの作成
5. レポーティング

とした場合、最後のレポーティングにおいて複数のシートを同時に印刷することになります。かつ、その場合には、GPAを入力したSheet1は印刷から除外することが想定されます。そのため、この作業を支援するため、Sheet1に新たに「本シート以外印刷」ボタンを設置しました。

　このボタンを押すと、Sheet1以外のシートを作業グループ化し、印刷ダイアログが立ち上がります。画面遷移を切っているため見た目は作業グループを確認することができませんが、印刷ダイアログでブック全体を選択せずともSheet1以外のシートが指定したプリンターにデータインします。印刷される順序は左から並んでいるシートの順番ですので、必要に応じて、「本シート以外印刷」ボタンを押す前に並び順を変更してください。

　なお、エクセルの仕様上すべてのシートをまとめて両面印刷する処理に手間がかかるため、両面印刷する場合は一旦PDFファイルに出力しそのPDFファイルを両面印刷してください。

「本シート以外印刷（氏名非表示）」機能

　上記の印刷作業において、個人情報のため氏名を非表示にする場合もあると思います。それを想定し、「本シート以下印刷（氏名非表示）」ボタンを設けました。基本的な動作は前述の「本シート以外印刷」と同じですが、シート中の0.23-0.27の頻度表に氏名が列記されていた場合、K列を非表示にし印刷後に再表示するようにしています。これにより、印刷時に氏名欄を削除することができます。

　なお、氏名が列記されたシートとそうではないシートが混在していた場合でも、氏名が列記されたシートのみを選択してK列を非表示にした上で、全体を印刷するようになっています。

ソースコード

Sub HISTOGRAM()



    Dim Target As Variant

    Dim Target2 As Variant

    Dim Target3 As Variant

    Dim Simei As Variant

    Dim Kikan As String

    Dim Gakubu As String

    Dim Nendo As Integer

    Dim Gakunen As Integer

    Dim Gakki As String

    Dim Tmp(1 To 3)

    Dim sh As Object

    Dim shname2 As String

    Dim num, NameLen As Integer

    Dim n As Integer

    Dim m As Integer

    Dim rank() As Double

    Dim i

    Dim j

    

    On Error GoTo Error         ' エラー処理

    

    Application.ScreenUpdating = False

    

    Set Target = Range("E:E")   ' データ範囲を格納

    Set Simei = Range("F:F")    ' データ範囲を格納

    Kikan = Cells(1, 2).Value   ' 機関名を取得

    Gakubu = Cells(2, 2).Value  ' 学部等名を取得

    Nendo = Cells(3, 2).Value   ' 年度を取得

    Gakunen = Cells(4, 2).Value ' 学年を取得

    Gakki = Cells(5, 2).Value   ' 学期を取得

    n = Cells(Rows.Count, "E").End(xlUp).Row    ' E列の最後の行数を取得

    shname = Gakubu & Nendo & "年度第" & Gakunen & "学年" & Gakki   ' シート名を設定

    NameLen = Len(shname)

    num = 2

    

    ReDim rank(n)           ' nを格納

    

    With WorksheetFunction  ' ヒストグラムの要素の幅，最小値，最大値を設定

        Tmp(1) = 0.2        ' ヒストグラムの要素の幅を設定

        Tmp(2) = 0          ' ヒストグラムの要素の最小値値を設定

        Tmp(3) = 4.2        ' ヒストグラムの要素の最大値を設定

        Columns("G:H").Clear

        For i = 1 To n      ' %順位を算出しSheet1に表示

            If Cells(i, 5) <> "" Then

                rank(i) = .PercentRank(Range("E:E"), Cells(i, 5), 5)

                Cells(i, 7).Value = rank(i)

            End If

        Next

        For i = 1 To n

            If Cells(i, 7) < 0.25 Then

                Cells(i, 8).Value = Cells(i, 7).Value

            End If

        Next

    End With

    

    Set Target2 = Range("G:G")              ' sheet1の順位を格納

    Set Target3 = Range("H:H")

    

    Range("G:H").Borders.LineStyle = True   ' %順位に罫線を引く

    

Step1:                                              ' シートを追加する際に同一名称のシートが既にあれば名称の後部にナンバリング

    For Each sh In Worksheets

        If sh.Name = shname Then

            shname = Left(shname, NameLen) & "(" & num & ")"

            num = num + 1

            GoTo Step1

        End If

    Next sh

    

    Sheets.Add.Name = shname    ' シートを追加

    

    ' 度数分布表の作成

    Cells(1, 1).Value = Kikan & " " & Gakubu & " " & Nendo & "年度 第" & Gakunen & "学年" & " " & Gakki

    Cells(2, 1).Value = "▼GPA度数分布表"

    Cells(3, 1).Value = "区間（下境界≦X＜上境界）"

    Cells(3, 3).Value = "度数"

    Cells(3, 4).Value = "最大度数"

    Cells(3, 5).Value = "累積度数"

    Cells(3, 6).Value = "累積頻度"

    Range(Cells(3, 1), Cells(3, 6)).Interior.ColorIndex = 15

    

    With WorksheetFunction      ' 表に数値を入力

        For i = 0 To (Tmp(3) - Tmp(2)) / Tmp(1) - 1

            Cells(i + 4, 1).Value = Tmp(2) + Tmp(1) * i

            Cells(i + 4, 2).Value = Tmp(2) + Tmp(1) * (i + 1)

            Cells(i + 4, 3) = .CountIfs(Target, ">=" & Cells(i + 4, 1).Value, Target, "<" & Cells(i + 4, 2).Value)

            Cells(i + 4, 5) = .Sum(Range(Cells(4, 3), Cells(i + 4, 3)))

            Cells(i + 4, 6) = Cells(i + 4, 5) / .Count(Target)

        Next

        Cells(4, 4).Value = .Max(Range(Cells(4, 3), Cells(i + 4, 3)))

    End With

    

    ' 度数分布表の書式設定

    With Range("A3:B3")

        .Merge

        .HorizontalAlignment = xlCenter

        .ShrinkToFit = True

    End With

    Range("C3:F3").HorizontalAlignment = xlCenter

    Range(Cells(3, 1), Cells(i + 3, 6)).Borders.LineStyle = True

    Range(Cells(3, 1), Cells(i + 3, 2)).Borders(xlInsideVertical).LineStyle = False

    With Range(Cells(4, 1), Cells(i + 3, 1)).HorizontalAlignment = xlRight

    End With

    With Range(Cells(4, 2), Cells(i + 3, 2))

        .NumberFormatLocal = "G/標準"

        .HorizontalAlignment = xlRight

    End With

    ActiveWindow.DisplayGridlines = False

        

    ' グラフ作成

    Range(Cells(3, 3), Cells(i + 3, 4)).Select

    ActiveSheet.Shapes.AddChart(xlColumnClustered).Select ' 集合縦棒グラフを作成

    

    With ActiveChart

        .HasLegend = False                      ' 凡例除去

        .ChartGroups(1).GapWidth = 0            ' 間隔=0

        .HasTitle = True                        ' グラフタイトルあり

        .ChartTitle.Text = Gakubu & " " & Nendo & "年度 第" & Gakunen & "学年" & " " & Gakki & " " & "GPA分布"    ' グラフタイトル

        .ChartTitle.Format.TextFrame2.TextRange.Font.Size = 12  ' グラフタイトルフォントサイズ

    With .SeriesCollection(1)

        .AxisGroup = 2                      ' 柱→2軸

        .Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent3 ' 柱の色→グレー

        .Border.Color = vbWhite             ' 柱の外枠線色→白

        .Border.Weight = xlThin             ' 柱外枠の太さ

    End With

    With .SeriesCollection(2)

        .ChartType = xlXYScatter            ' 最大度数→散布図へ

        .MarkerStyle = xlMarkerStyleNone    ' マーカーを不可視に

    End With

    With .Axes(xlCategory)

        .MinimumScale = Tmp(2)              ' 軸スケール合わせ（最小値）

        .MaximumScale = Tmp(3)              ' 軸スケール合わせ（最大値）

        .MajorUnit = Tmp(1)                 ' 軸スケール合わせ（目盛り）

        .CrossesAt = Tmp(2)                 ' 軸スケール合わせ（交点）

    End With

    With .Axes(xlCategory, xlPrimary)

        .HasTitle = True                    ' x軸タイトルを表示する

        .AxisTitle.Characters.Text = "GPA"  ' x軸タイトル

    End With

    With .Axes(xlValue, xlPrimary)

        .HasTitle = True                    ' y軸タイトルを表示する

        .AxisTitle.Characters.Text = "人数" ' y軸タイトル

    End With

    With .Axes(xlValue, xlSecondary)

        .TickLabelPosition = xlNone         ' 2軸ラベルを不可視に

        .MajorTickMark = xlNone             ' 2軸目盛を不可視に

    End With

        .Parent.Top = Range("M3").Top           ' 位置調整（上端）

        .Parent.Left = Range("M3").Left         ' 位置調整（左端）

    End With

    

    With Worksheets(shname).PageSetup         ' シートを1ページに印刷する設定

        .Orientation = xlLandscape

        .Zoom = False

        .FitToPagesTall = 1

        .FitToPagesWide = 1

    End With

    

    Range("M2").Value = "▼ヒストグラム"        ' ヒストグラム箇所がわかるように表示

    

    ' 累積頻度表の作成

    Cells(3, 8).Value = "累積度数"

    Cells(3, 9).Value = "累積頻度"

    Cells(3, 10).Value = "GPA"

    Cells(3, 11).Value = "氏名"

    Range("H3:K3").HorizontalAlignment = xlCenter

    Range("H3:K3").Interior.ColorIndex = 15

    

    j = 1

    For i = 1 To n

        If Sheets("sheet1").Cells(i, 7).Value <= 0.27 And Sheets("sheet1").Cells(i, 7).Value >= 0.23 Then

            Cells(3 + j, 9).Value = Sheets("sheet1").Cells(i, 7).Value

            Cells(3 + j, 8).Value = WorksheetFunction.CountIf(Target2, "<=" & Cells(3 + j, 9).Value)

            Cells(3 + j, 10).Value = Sheets("sheet1").Cells(i, 5).Value

            Cells(3 + j, 11).Value = Sheets("sheet1").Cells(i, 6).Value

            j = j + 1

            Range(Cells(3, 8), Cells(3 + j - 1, 11)).Borders.LineStyle = True

        End If

    Next i

        

    Range(Cells(3, 8), Cells(3 + j - 1, 11)).Sort Key1:=Range("I4"), Order1:=xlAscending, Header:=xlYes     ' 並び替え

    

    Columns("K").AutoFit     ' K列の幅を自動調整

  

    Range("H2").Value = "▼累積頻度0.23〜0.27"  ' 累積頻度表の箇所がわかるように表示

    

    ' GPA下位25%以下の人数表の作成

    

    Range("M16").Value = "▼GPA下位4分の1に属する人数"       ' GPA下位25%以下の人数表箇所がわかるように表示

    

    With Range("N17:P17")                               ' セルの結合

        .Merge

        .HorizontalAlignment = xlCenter

        .ShrinkToFit = True

    End With

    With Range("N18:P18")                               ' セルの結合

        .Merge

        .HorizontalAlignment = xlCenter

        .ShrinkToFit = True

    End With

    Cells(17, 13).Value = "総数"

    Cells(17, 14).Value = "GPA下位4分の1に属する人数"

    Cells(18, 13).Value = WorksheetFunction.Count(Target)                  ' sheet1GPA欄に入力された数を表示

             

    With WorksheetFunction

        If .CountIf(Target2, 0.25) >= 1 Or .CountIf(Target3, .Max(Target3)) = 1 Then    ' 累積頻度0.25が1つ以上、又は、累積度数0.25未満の最大値が1つ存在する場合

            Cells(18, 14).Value = .CountIf(Target2, "<0.25")    ' 累積頻度0.25以下の合計を表示

        Else                                                        ' その他（累積頻度0.25未満の最大値が複数存在する場合）

            Cells(18, 14).Value = .CountIf(Target2, "<0.25") - .CountIf(Target3, .Max(Target3))    ' 累積頻度0.25未満の数から累積頻度0.25未満の最大値の個数を除く

        End If

    End With

    Range(Cells(17, 13), Cells(18, 16)).HorizontalAlignment = xlCenter     ' セルの中央ぞろえ

    Range(Cells(17, 13), Cells(18, 16)).Borders.LineStyle = True           ' 罫線を引く

    Range("M17:P17").Interior.ColorIndex = 15                              ' 見出しの背景に着色

    

    If WorksheetFunction.CountA(Simei) = 0 Then Columns("K").Delete     ' 氏名欄に入力がない場合はK列を削除

    

    Application.ScreenUpdating = True

    

    Exit Sub

    

Error:      ' エラー処理

    

    If ActiveSheet.Name = shname Then

        Application.DisplayAlerts = False

        ActiveSheet.Delete

        Application.DisplayAlerts = True

    End If

    

    MsgBox "エラーが発生しましたので終了します。エラー内容:" & Err.Description



End Sub



Sub DateClear() ' データ消去



    Range("B2:B5").ClearContents

    Range("E:H").ClearContents



End Sub



Sub SheetDelete()   ' アクティブなシート以外を消去



    Dim sh As Worksheet

    

    With Application

        .DisplayAlerts = False

            For Each sh In Worksheets

                If sh.Name <> ActiveSheet.Name Then

                    sh.Delete

                End If

            Next

        .DisplayAlerts = True

    End With



End Sub



Sub BookPrint()         ' Sheet1以外を印刷



    Dim shno As Long    ' シートの数を定義

    Dim arr() As String ' シートの配列を定義

    Dim n

    Dim i

    

    Application.ScreenUpdating = False

    

    shno = Sheets.Count             ' ブック内のシート数を取得

    If shno = 1 Then Exit Sub       ' シート数が1（Sheet1のみ）だった場合に処理を終了

    ReDim arr(1 To shno - 1)        ' シート数から1を引いた数を配列に格納

    

    n = 1                                   ' シート名がSheet1ではないシートを配列に格納

    For i = 1 To shno

        If Sheets(i).Name <> "Sheet1" Then

            arr(n) = Sheets(i).Name

            n = n + 1

        End If

    Next i

    

    Sheets(arr).Select                          ' シート名がSheet1ではないシートを配列に選択

    

    Application.Dialogs(xlDialogPrint).Show     ' 印刷ダイアログを表示

    

    Sheets("sheet1").Select                     ' 作業グループの選択を解除しSheet1のみを選択

    

    Application.ScreenUpdating = True



End Sub



Sub BookPrintExcName()         ' 氏名を非表示にしてSheet1以外を印刷



    Dim shno As Long    ' シートの数を定義

    Dim arr() As String ' シートの配列を定義

    Dim n

    Dim i

  

    Application.ScreenUpdating = False

            

    shno = Sheets.Count             ' ブック内のシート数を取得

    If shno = 1 Then Exit Sub       ' シート数が1（Sheet1のみ）だった場合に処理を終了

    ReDim arr(1 To shno - 1)        ' シート数から1を引いた数を配列に格納

    

    n = 1                                   ' シート名がSheet1ではないシートを配列に格納

    For i = 1 To shno

        If Sheets(i).Name <> "Sheet1" Then

            arr(n) = Sheets(i).Name

            If Sheets(i).Cells(3, 11).Value = "氏名" Then   ' K3セルが氏名だった場合K列を非表示

                 Sheets(i).Columns("K").Hidden = True

            End If

            n = n + 1

        End If

    Next i

    

    Sheets(arr).Select                          ' シート名がSheet1ではないシートを配列に選択

    

    Application.Dialogs(xlDialogPrint).Show     ' 印刷ダイアログを表示

                                

    For i = 1 To shno

        If Sheets(i).Cells(3, 11).Value = "氏名" Then   ' K3セルが氏名だった場合K列を表示

            Sheets(i).Columns("K").Hidden = False

        End If

    Next i

    

    Sheets("sheet1").Select                     ' 作業グループの選択を解除しSheet1のみを選択

    

    Application.ScreenUpdating = True

        

End Sub