大学はどのように避難所の運営に関われるのか。

鍵の所在不明、避難所開けず 埼玉県幸手市の2カ所|全国・海外のニュース|徳島新聞

市の危機管理防災課によると、13日午前1時に災害対策本部を設置し、避難所開設を始めた。小中学校や市の施設は市で管理していた鍵で開けられたが、幸手看護専門学校と日本保健医療大の校舎については鍵の所在が分からず、学校側とも連絡が取れなかったため、開けなかった。

 多くの大学が避難所として指定されている中いつかこのような問題が生じるだろうなと思っていましたが、やはり発生していたようですね。

 避難所の運営は基本的には市町村が行うでしょうが、平時はともかく、特に今回のように休日の夜間など一般的に大学が閉鎖(事務局の大半が不在)している時は大学側が扉の解鍵や備品の準備を主導しなければなりません。

 おそらく、今回のようなケースには、

  1. 市町村職員が大学へ到着
  2. 守衛室から関係する大学職員へ連絡
  3. 関係する大学職員が大学に到着
  4. 関係する大学職員が市町村職員と連携して扉の解錠、備品の準備等を行う

のような順序で対応することになるでしょう。この場合、3.の職員が到着することができるのか、4.の職員が適切に対応できるのかがポイントになりそうです。私自身、一時期は勤務校の非常に近くに住んでいましたし、災害避難情報を踏まえ深夜に勤務校に避難(と言う名の所掌業務の災害対応)したこともあります。個人的には担当部署に災害時の初期対応について確認もしていましたが、もしその時になった場合はどの程度の権限で動けるのか不安でした。

 例えば、信州大学は避難所等の運営協力に関する基本指針を公表していますし、東日本大震災などの対応経験も活かせるところが多くあります。このあたりも参考にしたいところです。

 普段、(なぜかすでに災害対策本部テントが設営してある)避難訓練や(なぜか普段倉庫にしまってある備品がすでに机の上にある)避難誘導訓練を行うこともありますが、市町村役場と連携した避難所設営訓練も必要だなと感じたニュースでした。

修学支援新制度の対象から大学院生が除外されている件について

next49.hatenadiary.jp

 修学支援新設度(以下、「新制度」という)については、確認申請書の提出締め切りが過ぎ、各確認者にて確認を行っているところでしょうか。そんな中、新制度の対象に大学院生が含まれていないことについて話題になっています。この件について、整理してみます。

事実関係の整理

文科省のQ&A

高等教育段階の教育費負担新制度に係る質問と回答(Q&A):文部科学省

Q67 大学院生は新制度の支援対象になりますか。

A67 大学院生は対象になりません。(大学院への進学は18歳人口の5.5%に留まっており、短期大学や2年制の専門学校を卒業した者では20歳以上で就労し、一定の稼得能力がある者がいることを踏まえれば、こうした者とのバランスを考える必要があること等の理由から、このような取扱いをしているものです。)

 文部科学省のQ&Aでは、新制度の対象から大学院が除かれていることが明記されています。なお、従前から国費にて各大学で行われてきた授業料減免・入学料免除制度では、大学院生や留学生も対象に含まれています。今回は、従前からある減免・免除制度と新制度との対象者の違いにより、それまで支援を受けられていた大学院生が支援を受けられなくなるのではないかという懸念から生じているのでしょう。

新しい経済政策パッケージ

 新制度に大学院生を含まないことは、文部科学省の制度設計ではなく、内閣が決定した方針にてすでに決まっていました。ただし、これがどのように決まったのかまでは調べきれませんでした。

新しい経済政策パッケージ(平成29年12月8日閣議決定)

第2章 人づくり革命

3.高等教育の無償化

最終学歴によって平均賃金に差があることは厳然たる事実※5である。また、貧しい家庭の子供たちほど大学への進学率が低い、これもまた事実である。貧困の連鎖を断ち切り、格差の固定化を防ぐため、どんなに貧しい家庭に育っても、意欲さえあれば専修学校、大学に進学できる社会へと改革する。所得が低い家庭の子供たち、真に必要な子供たちに限って高等教育の無償化を実現する※6。

※6高等教育の無償化は、大学、短期大学、高等専門学校、専門学校について行う。

2−4

文科省のエージェンシー化

 余談ですが、最近の文教政策は内閣府財務省、政権与党などの会議体で目的・目標や方針が決まり、文科省はそれを実行するだけという、ある意味で文科省独立行政法人化(エージェンシー化)が進んでいると強く感じています。

なぜ大学院生が除外されているのか

修学支援新制度の目的は少子化対策である

 前述の「新しい経済政策パッケージ」の策定時点で大学院生が新制度の対象から除外されています。同パッケージの策定過程が公表されていないため、なぜ大学院生が除外されているのかは明確ではありません。ただ、新制度の趣旨が少子化対策であることに関係しているのではないかと考えています。

大学等における修学の支援に関する法律

(目的)

第一条この法律は、真に支援が必要な低所得者世帯の者に対し、社会で自立し、及び活躍することができる豊かな人間性を備えた創造的な人材を育成するために必要な質の高い教育を実施する大学等における修学の支援を行い、その修学に係る経済的負担を軽減することにより、子どもを安心して生み、育てることができる環境の整備を図り、もって我が国における急速な少子化の進展への対処に寄与することを目的とする。

 あまり知られていませんが、大学等における修学の支援に関する法律の目的は少子化の進展への対処に寄与することです。学費の無償化と少子化との関係はイメージにしにくいところであり、条文中には「修学に係る経済的負担を軽減することにより、子どもを安心して生み、育てることができる環境の整備を図」りとありますが、こじつけ感も覚えますね。このように少子化を法律の目的としたことは、同法を根拠として実施する修学支援新制度が消費税を財源としているためです。

消費税法

(趣旨等)

第一条 

2 消費税の収入については、地方交付税法(昭和二十五年法律第二百十一号)に定めるところによるほか、毎年度、制度として確立された年金、医療及び介護の社会保障給付並びに少子化に対処するための施策に要する経費に充てるものとする。

 平成24年8月に成立した「社会保障の安定財源の確保等を図る税制の抜本的な改革を行うための消費税法の一部を改正する等の法律」により消費税法の一部が改正され、消費税収入の使途が明記されました。

 その後、当初は消費税10%増税分収入は財政赤字の削減と社会保障費の充実に充てられる予定でしたが、その中から「人づくり革命」と呼ばれる少子化対策に充てられるよう使途変更が行われました。

消費増税による増収分の使途変更(みずほインサイト2017.9.26)

消費税増税の使い道をわかりやすく解説 | 消費税・軽減税率情報Cafe

 よって、消費増税を原資とする奨学支援新制度においては、少子化に対処すること以外に目的を設定する選択肢はない状況だったと言えます。このことは、文科省専門家会議の委員だった小林・東京大学教授も解説しています

 ここから、今回の新制度は既存の授業料減免・入学料免除制度とは、全く趣旨が異なるもの(継続性がないもの)と考えられます。大学院生を新制度の対象外とすることについては研究力やイノベーション誘発力の低下などの意見も見られましたが、そもそも制度の目的が異なるということですね。

 とは言っても免除者は継続的に存在しているため、どのように対応していくのかが問題になっています。

大学院は一般的な学歴のゴールとして想定されていないのではないか

 ここから先は全て私の推測です。

 新制度の対象は、大学・短大・高専・専門学校等と概ね18歳の進学先を網羅しています。ここから、奨学制度と言いつつも、特定の世代(主として18歳から22歳、またその親世代)への支援制度とも言えるのではないかと感じています。特定の世代に広く支援する場合、社会一般としてどのように整理をつけるかということが重要になります。その意味では、社会一般としてのストレートの学歴ゴール(あまりいい言葉ではありませんが。。。)として、新制度の対象となっている学校種が整理されたと考えることができます。(本来ならば、住民税非課税世帯やそれに準ずる世帯の進学状況を踏まえて検討すべきだと思いますが、それを見つけることができませんでした。。。)

 平成29年度就業状況基本調査から、15歳以上の最終学歴を以下の通り整理します。

f:id:samidaretaro:20190727102102p:plain

 大学院進学割合を考えると、原資が限られていることもあり、やはり大学・短大等をひとまずのゴールと置いたのでしょうか。

今後の展開

国会審議の状況

 次年度以降、大学院生や留学生に対する授業料減免・入学料免除の措置がどのようになるか、気になるところです。大学によっては億単位の原資が必要となるため、やはり国費の投入がなければ対応は難しいかもしれません。最近の国会審議の状況からは、以下の通りの発言が見受けられます。

198 - 衆 - 財務金融委員会 - 13号 令和01年05月15日

○森政府参考人 特に国立大学の運営費交付金の授業料減免の予算措置につきましては、経済的な理由、それから留学生、大学院生等を含めまして措置をしております。
 その中で、実際の、先ほど申し上げましたように繰り返しになりますけれども、どのような所得要件にするか、新制度においては住民税の課税標準額をベースにいたしますけれども、各大学においては年収基準をもとにしているところが多いわけでございますけれども、それについてはそれぞれの大学で決めてきた、そういうことでございます。

○宮本委員 ですから、それぞれの大学で、今回の法律よりももっと大きな幅で減免をやってきたわけですよ。それを支援してきたわけですよ。そして、もっと対象を拡大しなきゃいけないということで、ずっと積み上げてきたわけじゃないですか。なぜその認識を捨てようとするのか。
 私、国の今度の施策によって、授業料減免の対象が縮小する大学が生まれるというのは、国連人権規約にあります高等教育の漸進的無償化に逆行すると思いますよ。その点の認識、文科副大臣、いかがですか。

○永岡副大臣 お答えいたします。
 国際人権規約におきまして、無償教育の具体的な方法については特段の定めをしておりません。その範囲や方法を含めまして、具体的にどのような方法をとるかについては加盟国に委ねられております。
 文部科学省としては、財政や進学率等その時々の状況を総合的に判断しながら、具体的な、給付型の奨学金制度の創設を始め、奨学金制度を充実させるなど、教育費負担の軽減に努めているものでございます。
 新制度は、真に支援が必要な学生に対しまして確実に授業料等が減免されるよう、大学等を通じた支援を行うとともに、学生生活の費用をカバーするために十分な給付型の奨学金を支給するものでございます。全体としては、規模や金額が大幅に拡大することで支援が広がっていくものと考えております。
 このため、中長期的に見まして、無償教育という手段を徐々に、漸進的に導入する方向に沿って努力していく方針が維持され、そして実際の施策が中長期的に見ましてその方向性に沿ったものとなっていることから、無償教育の漸進的導入の趣旨に適しているものと認識をしている次第でございます。

○宮本委員 私は、今度の法律について適しているかどうか聞いたわけじゃないんですね。法律は成立しました、法律が成立したもとで、今度、今まで続いてきた授業料の減免制度をどうするかということが問われているわけですよ。今までの授業料減免制度は法律に基づいてやっているわけじゃないですから。
 この減免制度を縮小していくということになったら、これは当然、漸進的無償化というのは前に進んでいくわけですから、その部分が対象が少なくなるというのは、明確に逆行するということを言わなければいけないと思います。
 私、本当に大変心配するのは、先ほど来、各大学で減免制度は考えてくれということを大臣はおっしゃるわけですよね。これは、今まで同様の財政措置がなくなったらどうなるかということなんですよね。
 各大学は、そうはいっても、やはり減免制度を続けたいと思いますよ。自主財源を確保しようという話になりますよ、もし財政措置がとられなければ。寄附金が集まればいいですけれども、寄附金が集まらなければどうなるのか。自主財源といったら、授業料を上げることになるんですよね。実際、ずっと据え置かれていた国立大の授業料ですけれども、ことし、東工大と芸大が値上げするということになりました。
 ですから、私が本当に言っておきたいのは、減免制度を各大学で維持する財源を学生や父母に求めるような、授業料値上げで賄うようなことは絶対あってはならない、そういう方向に誘導しては絶対ならないと思いますが、その点の文科副大臣の認識をお伺いしたいと思います。

198 - 参 - 文教科学委員会 - 7号 令和01年05月09日

○神本美恵子君 (略)
 一番大きな問題は、この間の現行の授業料減免について、文科省は留学生や大学院生については目的が異なるので継続して支援するとされておりますけれども、今受けている在学中の、現行制度で授業料減免を受けている、そういう人たちに対しては対策がちゃんと取られるのかということについて聞いたら、国立大学については何らかの配慮が必要かどうか検討中、また、私立については、現行の私立大学等経常費補助金配分基準で授業料減免事業等支援がありますけれども、新制度に移行した後どうなるかということについてははっきりおっしゃっていないんですね。大学の対応を見極めつつというような答弁がされておりますけれども、現行の制度が後退、縮小する懸念は拭えていないんです、これまでの議論では。
 大臣、はっきりここは後退しないと、縮小しないというふうに、それだけの予算獲得をするんだということを明言していただきたいと思います。いかがですか。

国務大臣柴山昌彦君) 現行の各大学における授業料減免は、それぞれが定める認定基準に基づいて本当に多様な形で行われております。これが、新制度の下では、二〇二〇年度から各大学における授業料減免への公的支援が、国公私を通じ、全国で統一的な基準によって真に支援が必要な住民税非課税世帯及びこれに準ずる世帯の学生に対して重点的に行われることになるというように考えております。総合的な支援の額は大幅に増えてまいります。
 それでは、個別の大学についてどうかということなんですけれども、今後、各大学においてこの新制度を踏まえてどのように対応するかということをそれぞれ検討していただくこととなりますけれども、文部科学省といたしましては、本年夏頃までをめどとして、必要な調査等を行った上で適切に対応してまいりたいと考えております。

○高木かおり君 (略)
 続きまして、もう最後の質問になるかもしれませんが、先ほどもお話が出ていましたが、大学の学費の値上げで一番打撃を受けるというのは、やっぱり中間層であるというふうに思います。我が党は、そもそも所得制限なしの大学、高等教育の無償化を訴えてはおりますけれども、今少しずつ前進していく中でも、やはりこの中間所得層の学生さんたちが大変今困難な状況にあるというふうに思います。学生さんたちがプロジェクトを立ち上げた中でのアンケートによりますと、世帯年収四百万から八百万の世帯の学生さんたちが、もう高い学費ということに、こういった壁に大変悩んでいるということをお聞きをいたしました。
 今までは、国立大学の場合に限りますけれども、国立大学の場合、大学院生ですとか、年収が先ほど申し上げた中間所得層の中でも、成績が良かったら授業料の減免を受けることができたという制度もありました。だけれども、今回の新制度によって、こういったことに対しても減免措置が打ち切られたり後退するということがあるのかどうか。これは大学が決めることだというふうな御回答かもしれないんですけれども、やはりこういったことも大学が、じゃ、やめようかというふうになってしまうということではやはり後退ということになってしまうのかなというふうに感じるんですけれども、その点はどうでしょうか。

○政府参考人(伯井美徳君) 新制度の下におきましては、まず、この新制度に基づく統一の基準による支援制度ができると、その上で、それを踏まえて各大学がどのように対応するかということでございます。
 今後、国立大学につきましては、各国立大学において新制度を踏まえてどのように対応するか、それぞれ検討していくわけでございますが、その中で、先般大臣もお答えされましたように、新制度において対象とならない学生も生じ得るというところでございます。それにつきましては、当該学生の学びの継続を支援するという観点から、減免の事由、家計基準の実態、国立大学における減免基準の考え方などを見極めつつ、一定の配慮について検討をしていくことが必要であるというふうに考えております。
 そのため、文科省としては、各国立大学に対して一定の調査をするなどいたしまして、より詳細な状況を把握した上で新たな制度の趣旨を踏まえ、適切に対応していきたいというふうに考えております。

198 - 参 - 文教科学委員会 - 5号 平成31年04月23日
斎藤嘉隆君 是非大臣、本当にこれ学生たちにとっては死活問題なので、新制度で七千数百億円という予算で非課税世帯の子供たちが大学に行きやすくなるというのは、これは本当に有り難いことだと思いますけれども、そのことの導入と引換えに従来の五百数十億円という予算が削られて各大学の減免が縮小していくなんということがあったら、これはむしろマイナスの方が大きい、そのように言わざるを得ないんです。
 もう一点お聞きします。
 大学院生への支援、新制度は大学院生対象外ですね。これ、新制度によって従来の制度の継続が左右されるようなものではないと思います。二〇一九年度は一万七千人が免除対象ですけれども、二〇二〇年も、これは規模も含めて維持をしていくという方向でよろしいですか。
国務大臣柴山昌彦君) 今委員御指摘のとおり、今回の新たな支援制度は学部学生を対象としたものでありますけれども、ただ、国立大学の大学院生に対する授業料の減免は運営費交付金より別途措置されておりますので、引き続きしっかりと対応していきたいと考えております。

予算の話はまだ確実に言えない

 「しっかりと対応していきたい」とありますし、現に大学にそれらしい調査も来ています。ただ、概算要求事項も明らかになっていない中で来年度の予算のことは根拠なく話すことはできないと思います。そのため、今後の対応は不明というのが正確なところでしょう。もし文科省担当者が現時点で「大丈夫ですよ。継続されますよ。」と言ったのなら、ちょっと軽率だなという印象です。

 個人的には、最低限、従前からの減免・免除枠から今回の制度分を除外した金額を配分してほしいと考えています。

本件に関する所感

 そもそも、授業料減免・入学料免除を少子化対策として位置づけことが無理筋なのではないかと思います。予算の都合上タテマエとして設けた目的目標が後の行動を縛っていくという構図は大学でもよく見る風景だなと感じました。

大学評価基準をそのまま内部質保証に用いるのは困難ではないか。

※本稿では、大学改革支援・学位授与機構が行う大学機関別認証評価を想定して記述しています。

 教育の内部質保証活動においては、大学機関別認証評価の評価基準を活用する場合も多かろうと思います。それはそれでよいのですが、評価基準を内部質保証にそのまま使えるほど簡単な話ではありません。

内部質保証のモデル図

 内部質保証をいかにして表現するか、さまざま考えてきたのですが、最近は以下のとおり考えています。

f:id:samidaretaro:20190726074550p:plain

f:id:samidaretaro:20190726074604p:plain 

 要素としては、以下のとおり整理しています。

  • Focus:保証すべき質を決定する
  • Monitor:各種アセスメント手法を用いて状況を観察する
  • Feedback:観察結果に基づき、フィードバックを行う
  • Reaction:フィードバックに応答し、行動する

 弊ブログでも何度も言及してきましたが、内部質保証の実践においては、保証すべき「質」の検討が最も重要かつ困難であると考えています。そのため、まず保証すべき「質」を決定するFocusが必要です。また、Focusの結果、何を「質」として定めたかは、内部質保証を構成する組織間で共有する必要があります。
場合によっては、Reactionの結果により、Focusの見直しや別分野への移行などもあり得ますね。

 アセスメントを行っていれば内部質保証になるといった話も聞き及びますが、アセスメントはあくまでMonitorの一手段ではなく、それのみでは内部質保証を構成したことにはなりません。

大学評価基準の特徴

 一般的に、評価の方法は水準判定と到達度判定の2つに大別できます。

  • 水準判定:特定の水準を超えているかで評価する方法。Yes/Noで判定できる。大学設置基準における必要専任教員数の判断などが該当。
  • 到達度判定:目標等に対しどの程度到達できたかで評価する方法。国立大学法人評価などが該当。

 大学評価基準は、基準を満たしている/満たしていないで判定する水準判定に分類できるでしょう。

 一方、同基準のなかには目指すべき水準を明記していない場合が多く、判断する水準自体を大学が考える必要があります。これは、認証評価自体が大学の自己点検・評価を基盤にしている証左でしょう。

大学評価基準をそのまま内部質保証に用いる危険性

ここまでの話を以下の2点にまとめます。

  1. 内部質保証には「質」の検討が重要である
  2. 大学評価基準には目指す水準が明記されていない

 大学評価基準に明記されていない「水準」とは「質」のことでもあると考えられ、その前提では、大学評価基準には「質」が明記されていないと言えます。そのため、大学評価基準をそのまま内部質保証の基準として用いる場合、拠り所となる多数の基準において向上させるべき「質」が不明であり、大学の質保証の取組が迷走することも想定できます。大学評価基準にはゴールが書かれていないのですから。

 一方、改正された学校教育法第109条第6項では認証評価の認定を受けるように努力することとなっており、大学評価基準を無視することもできません。

 そうなると、学内の他の事項(中長期計画や事業計画など)と認証評価基準とを関連付け、それを踏まえて内部質保証に対応することがよいのではないかと考えています。特に、私立大学であれば、改正された私立学校法により事業に関する中期的な計画の作成が義務付けられたこともあり、既存の計画も含め、しっかりと関連付けていきたいところです。(カバーできない基準は落穂拾い的に対応していくことになるでしょう)

内部質保証の本質

 ところで、内部質保証の本質は、組織間の対話・交渉であると考えています。この前提に立つと、一般的に調整役になることが多い事務職員にとっては、活躍できる場面もあるのではないでしょうか。逆に言えば、没交渉である組織が存在する場合の内部質保証をどのように担保すべきかは、考えなければなりません。

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

文科省Q&A更新の影響

高等教育段階の教育費負担新制度に係る質問と回答(Q&A):文部科学省

Q101
GPA等の客観的指標が、学部等で下位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以下の個数の合計としていました。しかし、文科省の見解では、ライン上に複数名が存在している場合は全員を警告ラインから除外するとしています。これは、下図の通り整理できます。

f:id:samidaretaro:20190708192314p:plain

 これについて、一晩かけて対応を検討し、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未満の個数

f:id:samidaretaro:20190708192224p:plain
 文科省の言う「下位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. 下位4分の1の人数がわかる表を作成(前述)
  2. 累積頻度0.25前後の者がわかる表を作成
  3. 「本シート以外印刷」機能
  4. 「本シート以外印刷(氏名非表示)」機能

f:id:samidaretaro:20190706134732p:plain

※上記図中の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

 

(ファイル公開停止)修学支援新制度のためGPA分布表作成マクロを改変しました。

文科省のQ&Aに対応していなかったので、ファイルの公開を停止しています。

kakichirashi.hatenadiary.jp

 前回GPA分布表作成マクロを作成したところですが、文科省への事前相談において下位25%以下の人数を分布図中に明記するように指摘された旨の話を耳にしました。この指摘には前回作成したVer1では対応できないため、若干コードを加筆し、下位25%の人数を明記できるようにしたVer2を作成しました。

※GPA下位25%の算出方法が明らかになり当該マクロの算出方法と異なっていたため、公開を中止します。

f:id:samidaretaro:20190701210506p:plain

 ヒストグラムの下に、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

修学支援新制度のため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

修学支援新制度で注意したい3点

 修学支援新制度は、そろそろ事前相談が行われている頃でしょうか。修学支援新制度においては、現時点で、以下の3点を注意したいと考えています。

1.授業料減免のスケジュール等

 授業料減免は大学等側が対応することになっています。JASSOが行う学資給付金の認定に合わせて対応すれば良いと思うのですが、スケジュールや申請様式等については大学等側で策定しなければなりません。説明会では、文科省から統一スケジュール等が示されるかもしれないとの話でしたので、それも待ちつつ考えていきたいですね。

2.GPAの算出方法

 申請書ではGPAの分布状況に係る資料を提出することになっており、それは原則として1年生の分布であることがすでにQ&Aに示されています。それは良いのですが、継続の判断(適格認定)をする際にもGPAが用いられます。具体的には、GPAが下位25%以下であれば、警告を行うことになります。

 適格認定に係るGPAの算出については、どの範囲でどのように行うのか(学年ごとなのか、前後学期なのか通年なのか、標準修業年限が異なる学科はどうするのか)が、いまいち判然としません。こちらも、説明会にて文科省からGPAの算出方法について通知があるような話がありましたので、それを待ちつつGPA分布を確認できる方法や時期を検討することになるでしょう。

3.既存の支援制度との関係

 新制度と既存の支援制度を比較し、該当しなくなる者への対応をどうするかはシビアな問題だと認識しています。

 特に、国立大学では、旧来の一般運営費交付金の特殊要因経費について授業料全額半額免除の予算が計上されてきました。

<2019年度文部科学関係予算(案)主要事項>

f:id:samidaretaro:20190615195820p:plain

 この予算がどのようになるのかも含めて、検討が必要だと考えています。