（ファイル公開停止）修学支援新制度のためGPA分布表作成マクロを改変しました。
※文科省のQ&Aに対応していなかったので、ファイルの公開を停止しています。
前回GPA分布表作成マクロを作成したところですが、文科省への事前相談において下位25%以下の人数を分布図中に明記するように指摘された旨の話を耳にしました。この指摘には前回作成したVer1では対応できないため、若干コードを加筆し、下位25%の人数を明記できるようにしたVer2を作成しました。
※GPA下位25％の算出方法が明らかになり当該マクロの算出方法と異なっていたため、公開を中止します。
ヒストグラムの下に、sheet1E列に入力されたGPAの入力数（全員の人数）と累積頻度0.25以下の数（下位25%以下の人数）を明記するようにしました。使用方法はVer1と同様です。
なお、私はこの分布表を根拠資料として使用していませんので、実際に申請に使用できるかどうかはわかりません。各機関でご判断願います。
Sub HISTOGRAM() Dim Target As Range Dim Target2 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) ' 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 Set Target2 = Range("F:F") ' sheet1の順位を格納 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 ' GPA下位25%以下の人数表の作成 Range("K16").Value = "▼GPA下位25%以下の人数" ' GPA下位25%以下の人数表箇所がわかるように表示 With Range("L17:N17") ' セルの結合 .Merge .HorizontalAlignment = xlCenter .ShrinkToFit = True End With With Range("L18:N18") ' セルの結合 .Merge .HorizontalAlignment = xlCenter .ShrinkToFit = True End With Cells(17, 11).Value = "総数" Cells(17, 12).Value = "GPA下位25%以下の人数" Cells(18, 11).Value = WorksheetFunction.Count(Target) ' sheet1GPA欄に入力された数を表示 Cells(18, 12).Value = WorksheetFunction.CountIf(Target2, "<= 0.25") ' sheet1順位欄の0.25以下の数を表示 Range(Cells(17, 11), Cells(18, 14)).HorizontalAlignment = xlCenter ' セルの中央ぞろえ Range(Cells(17, 11), Cells(18, 14)).Borders.LineStyle = True ' 罫線を引く Range("K17:N17").Interior.ColorIndex = 15 ' 見出しの背景に着色 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
