修学支援新制度では、申請時にGPA分布状況がわかる資料の提出が求められるとともに、継続時(適格認定時)においてもGPA下位25%にある支援者に対して警告措置を行わなければなりません。そのため、機関としてGPA分布状況を把握することが重要になります。その一助とするため、GPA分布表を自動生成するマクロファイルを作成しました。
GPA分布表作成マクロ
片手間に作成したので、CellsとRangeの使い分けなどしっかりとしたものではありません。なお、作成に当たっては、「静粛に、只今統計勉強中」さんのソースコードをベースにさせていただきました。ありがとうございます。また、内容の正確性は保証するのではなく、使用は自己責任でお願いします。動作確認はWin10Ofiice2017で行っています。
ファイルは、sheet1というワークシートで構成されています。黄色で着色された箇所がユーザーの入力箇所です。
まずは、sheet1のB1-B5セルに機関名、学部等名、年度、学年、学期を入力します。年度及び学年は自然数を入力してください。ここに入力された機関名等が、分布表生成ワークシートの名前やヒストグラムのタイトルに反映されます。
次に、sheet1のE列にGPAを入力します。テキスト形式で縦に並べて入力(実際には恐らくコピペ)してください。昇順降順に並べる必要はなく、空欄があっても対応しています。
sheet1には、以下の3つのマクロボタンが設定されています。
- ヒストグラム作成
- データ消去
- 本シート以外削除
1は、新たなシートを作成し、入力されたデータを元に度数分布表やヒストグラムを表示します。新たなシートの名前はB2-B5セルに入力された学部等名、年度、学年、学期が反映されますが、同じ名前のシートが既に存在していても名前の後ろにナンバリングし新たなシートを作成します。
2は、B1以外の黄色セルのデータを消去します。例えば、A学部のGPA分布を作成した後、B1以外のデータを削除し、B学部のデータを入力してB学部のGPA分布を作成することなどを想定しています。こうすれば、1つのブックで複数の学部のGPA分布をシートごとに表示できます。
3は、sheet1以外のシートを削除します。テスト段階で1ボタンを押したくさんのシートを作成しまとめて削除していたので、その名残です。
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
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
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
.HasTitle = True
.ChartTitle.Text = Gakubu & " " & Nendo & "年度 第" & Gakunen & "学年" & " " & Gakki & " " & "GPA分布"
.ChartTitle.Format.TextFrame2.TextRange.Font.Size = 12
With .SeriesCollection(1)
.AxisGroup = 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
.AxisTitle.Characters.Text = "GPA"
End With
With .Axes(xlValue, xlPrimary)
.HasTitle = True
.AxisTitle.Characters.Text = "人数"
End With
With .Axes(xlValue, xlSecondary)
.TickLabelPosition = xlNone
.MajorTickMark = xlNone
End With
.Parent.Top = Range("K3").Top
.Parent.Left = Range("K3").Left
End With
With Worksheets(shname).PageSetup
.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