修学支援新制度のためGPA分布表作成マクロを作成しました。

 修学支援新制度では、申請時にGPA分布状況がわかる資料の提出が求められるとともに、継続時(適格認定時)においてもGPA下位25%にある支援者に対して警告措置を行わなければなりません。そのため、機関としてGPA分布状況を把握することが重要になります。その一助とするため、GPA分布表を自動生成するマクロファイルを作成しました。

GPA分布表作成マクロ

 片手間に作成したので、CellsとRangeの使い分けなどしっかりとしたものではありません。なお、作成に当たっては、「静粛に、只今統計勉強中」さんのソースコードをベースにさせていただきました。ありがとうございます。また、内容の正確性は保証するのではなく、使用は自己責任でお願いします。動作確認はWin10Ofiice2017で行っています。

f:id:samidaretaro:20190620075213p:plain

 ファイルは、sheet1というワークシートで構成されています。黄色で着色された箇所がユーザーの入力箇所です。

 まずは、sheet1のB1-B5セルに機関名、学部等名、年度、学年、学期を入力します。年度及び学年は自然数を入力してください。ここに入力された機関名等が、分布表生成ワークシートの名前やヒストグラムのタイトルに反映されます。

 次に、sheet1のE列にGPAを入力します。テキスト形式で縦に並べて入力(実際には恐らくコピペ)してください。昇順降順に並べる必要はなく、空欄があっても対応しています。

 sheet1には、以下の3つのマクロボタンが設定されています。

  1. ヒストグラム作成
  2. データ消去
  3. 本シート以外削除

 1は、新たなシートを作成し、入力されたデータを元に度数分布表やヒストグラムを表示します。新たなシートの名前はB2-B5セルに入力された学部等名、年度、学年、学期が反映されますが、同じ名前のシートが既に存在していても名前の後ろにナンバリングし新たなシートを作成します。

 2は、B1以外の黄色セルのデータを消去します。例えば、A学部のGPA分布を作成した後、B1以外のデータを削除し、B学部のデータを入力してB学部のGPA分布を作成することなどを想定しています。こうすれば、1つのブックで複数の学部のGPA分布をシートごとに表示できます。

 3は、sheet1以外のシートを削除します。テスト段階で1ボタンを押したくさんのシートを作成しまとめて削除していたので、その名残です。

f:id:samidaretaro:20190620075351p:plain

 1ボタンにより作成された新たなシートには、度数分布表と累積度数0.23-0.27のGPA、ヒストグラムが表示されます。前述の通り、赤枠のシート名、グラフ名はsheet1の学部等名などを反映させています。なお、画像のGPAは0.0から4.0の間で発生させた100個の乱数の度数分布結果であり、実際のGPAではありません。

 作成された新たなシートは、初期設定でA4横一枚に収めて印刷できるようにしてあるので、マクロボタン押下→シート印刷という最短でのレポーティングが可能です。(本当はヒストグラムの中に下位25%の線分を発生させたかったのですが私の技術ではできませんでした。。。)

 また、GPAは基本的には0.0−4.0の間の値を取るため、度数分布表は最小値0最大値4幅0.2で設定しています(最初はスタージェスの公式により階級数を算出していましたが煩雑になるため固定値としました)。ただ、最大値4では最後の階級が3.8以上4未満となりGPA4.0の者が反映されないため、最後の階級は4.0以上4.2未満としました。

 適格認定では、GPA分布下位25%の者に対し警告を与えることになっています。そのため、累積度数0.23から0.27のGPAを抽出し、表示しています。母数が少ないと0.23から0.27の間にGPAが表示されない可能性がありますが、その場合はVisualBasicを開きプログラムの157行目の数値を訂正してください。なお、プログラムを若干書き換えれば累積度数0.23から0.27のGPAの隣に氏名を表示させることも可能です。

 平成30年度学校基本調査によれば、各学校種の設置数は大学782校、短大331校、高専57校、専門課程を持つ専修学校2,805校であり、合計3,975機関です。全ての機関が申請するとして、1機関に1人が1時間をかけてGPA分布資料を作成し担当者の時給を2000円程度と仮定すると、総じて7,950,000円分程度は貢献できたでしょうか。これで少しでも担当者の労力が緩和できればいいな、と思っています。

Sub HISTOGRAM()

    

    Dim Target As Range

    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 rank() As Double

    Dim i

    Dim j

    

    On Error GoTo Error



    Application.ScreenUpdating = False

    

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

    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)

        

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

        Tmp(1) = 0.2

        Tmp(2) = 0

        Tmp(3) = 4.2

        Columns("F").Clear

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

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

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

        Next

    End With

    

    Range("F:F").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("H2").Value = "▼累積頻度0.23〜0.27"  ' 累積頻度表の箇所がわかるように表示

    ' グラフ作成

    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("K3").Top           ' 位置調整(上端)

        .Parent.Left = Range("K3").Left         ' 位置調整(左端)

    End With

    

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

        .Orientation = xlLandscape

        .Zoom = False

        .FitToPagesTall = 1

        .FitToPagesWide = 1

    End With

    

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

    

    ' 累積頻度表の作成

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

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

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

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

    j = 1

    For i = 1 To n

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

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

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

               j = j + 1

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

            End If

    Next i

        

    Range(Cells(3, 8), Cells(3 + j - 1, 9)).Sort Key1:=Range("H4"), Order1:=xlAscending, Header:=xlYes

    

    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:F").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