[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAでグループ分け』(misaki)
簡潔に言いますと40人の生徒を成績が平等になるようなグループ分け(5人×8グループ)を行いたいのです。
また、フォームで成績優先というオプションボタンを選択し、その上でグループ作成というコマンドボタンをクリックしたらデータが入力されているシートとは違うシートにグループ分けが反映される仕様にしたかったのですが、なかなかうまくいきません。
どなたか分かる方お願いします。
< 使用 Excel:Excel2013、使用 OS:Windows7 >
あと、元データのレイアウトが判る実例も挙げてください。どういうデータならばどういう結果になって欲しいのか。それが重要です。
点数合計が平等になる簡単なロジックは、点数順にソートしておいてから、一番上と一番下、というように、上下から交互にデータを取り出していく方法かと思います。いつも同じような顔ぶれになりそうですが、大丈夫ですかね? そのうち、生徒側で自分の位置を推測してしまいそう。
(???) 2016/10/13(木) 15:02
テーマは3つあるわけですね。
1.成績が平等になるようなグループ分け 2.フォーム(ユーザーフォームでしょうか?)のオプションボタンの選択有無によって処理分岐。 3.あるシートのデータを基にして作成した値を別のシートに書きこむ。
1.については、不得意なので、エキスパートさんからの回答をお待ちください。
2.は、なんとなくチェックボックスのほうが適切な感じがしますが、オプションボタンだとして
Private Sub グループ作成_Click() If 成績優先.Value Then 'ここに 処理コードを記述 End If End Sub
こんな感じになるでしょうね。
3.について、以下はサンプルです。Sheet1 と Sheet2 がある新規ブックで、試してください。
Sub Test() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim ans As Long
Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2")
'テストデータ作成 sh1.Range("A1").Value = 100 sh1.Range("A2").Value = 20
'処理サンプル
'Sheet1のデータを使って情報を作成 ans = sh1.Range("A1").Value / sh1.Range("A2").Value '結果をSheet2に書きこむ sh2.Range("F5").Value = ans
End Sub
(β) 2016/10/13(木) 15:17
グループの人数が奇数なのでなかなか上手くいかないと思いますが、
一番左のシートのA1:A40に成績順に名前が並んでいるとして、
左から2つ目のシートのA2から5行8列の範囲にできるだけ公平に
並べます。(出力側の偶数行を右から左に書き込む)
Sub test()
Dim rngFrom As Range Dim rngTo As Range Dim c As Range Dim i As Long, j As Long
Set rngFrom = Sheets(1).Range("A1:A40") Set rngTo = Sheets(2).Range("A2").Resize(5, 8) For Each c In rngFrom i = i + 1 If i Mod 8 = 1 Then j = j + 1 If j Mod 2 = 0 Then rngTo(j, rngTo.Columns.Count - (i - 1) Mod 8).Value = c.Value Else rngTo(i).Value = c.Value End If Next End Sub (まっつわん) 2016/10/13(木) 15:55
では私は、顔ぶれがいつも同じになる事を避けるため、元データを少しランダムに入れ替える案を出しましょう。完全ランダムにすると点数が平均化しないので、1〜4人分ランダムに近い点数の生徒を入れ替えてます。 これを実行(何度か実行してもOK)してから、まっつわんさんのマクロを実行してみてください。
Sub test1() Dim R As Range Dim cWk As String Dim iWk As Long Dim iw As Long Dim i As Long
Randomize Set R = Range("A1:B40")
For i = 1 To R.Rows.Count iw = Int(Rnd() * 4) + i + 1 If iw <= R.Rows.Count Then cWk = R(i, 1) iWk = R(i, 2) R(i, 1) = R(iw, 1) R(i, 2) = R(iw, 2) R(iw, 1) = cWk R(iw, 2) = iWk End If Next i End Sub (???) 2016/10/13(木) 16:43
数学的な詳しいことは解りませんが、
ニュースで野球のドラフトの話がでるじゃないですかぁ。
たしかこんな風な順番で選んでたような気がしたなぁと。。。。
あとは、試してそれっぽくなればオーケーかなと。。。
所詮その程度です><
(まっつわん) 2016/10/13(木) 18:34
私のテストデータでやってみると、あまり平準化されていなかったです。
理由を考えてみたのですが、例えばトップが突出していい点だとすると、 ワーストの1人だけじゃなく、ワースト2、下手すればワースト3も トップと組ませなくてはならない、と言う状況があるためだと思われます。
逆に、そんな組合せにしていいの? って問題もありますね。 出来のいい奴が自分のメンバーを見渡して、 まいったなぁなんて思うような者ばかりでもいけないかもです。
すると、機械的に平準化されていればいいってものでもないかも知れない。
グループ分けの趣旨は何なのでしょうねぇ。それが分からないと動けなくなります。
>フォームで成績優先というオプションボタンを選択し
今のところ、成績しか分類基準がないと思うのですが、 何故そんなオプションを選択する必要があるんでしょうか? 自明では?
他にもいくつか基準があって、今回はその第一歩だとしたら、少なくとも、 もう一つについても説明があってもいいのではないか、と思っちゃう。
じゃないと、ガラパゴス(他に適応力ない)回答になる懸念も生じてしまう。
VBAで対応しようということですから、高頻度で繰り返す処理なのだろうなぁとは思うのですが、 その必要性に思いを至す状況を私は感じ取れないです。
インプットとアウトプット、それぞれのレイアウトとサンプルデータの提示もほしい。
(半平太) 2016/10/14(金) 15:27
順位で単純に振り分けてますもんねー
テストの平均点を揃える方向だと、
も少し複雑に選ばないとだめですねー
(まっつわん) 2016/10/14(金) 16:02
まっつわんさん
済みません。これを考慮していなかったです ↓ >一番左のシートのA1:A40に成績順に名前が並んでいるとして
再テストしたところ、十分リーズナブルな結果になっていました。
ご容赦を・・ m(__)m
(半平太) 2016/10/14(金) 17:02
(とはいえ、質問者の方の返事がないですねぇ。。。。)
(まっつわん) 2016/10/14(金) 17:14
>その、なかなかうまくいかない、という状態のコードを貼ってください。元が判らないと、何をアドバイスすれば良いのか判りませんので。
なかなか上手くいかないという表現が悪かったですね。どうすればいいのか分からないのほうが適切でしたすみません。
>あと、元データのレイアウトが判る実例も挙げてください。
A B C D E F G 1 出席番号 名前 点数 性格分析 友達1 友達2 友達3 2 1 A 75 TG型 2 3 8 3 2 B 80 AN型 5 8 10 4 3 C 65 ML型 8 1 12 5 4 D 58 ML型 10 11 14 6 5 E 90 AN型 15 13 9 7 6 F 76 AN型 14 12 7 8 7 G 82 LM型 12 15 6 9 8 H 70 AN型 18 2 5 10 9 I 68 ML型 1 4 15 11 10 J 78 ML型 4 9 11 12 11 K 98 AN型 11 5 1 13 12 L 66 AN型 9 7 2 14 13 M 55 ML型 8 6 4 15 14 N 71 AN型 3 14 6 16 15 O 81 AN型 2 9 13
というレイアウトでデータを入力し、
ユーザーフォームで成績優先、性格上での性格の相性優先、友人関係優先の3パターンの結果を
2枚目のシートに出席番号でグループが分かるように出力(これはサンプルですが)をしたいです。
A B C D E 1 1グループ 2 1 2 3 4 5 3 2グループ 4 6 7 8 9 10
このようなレイアウトで伝わりますでしょうか?
βさんありがとうございます。早速試してみようかと思います。
>グループ分けの趣旨は何なのでしょうねぇ。それが分からないと動けなくなります。
>今のところ、成績しか分類基準がないと思うのですが、
>何故そんなオプションを選択する必要があるんでしょうか? 自明では?
>他にもいくつか基準があって、今回はその第一歩だとしたら、少なくとも、
>もう一つについても説明があってもいいのではないか、と思っちゃう。
>じゃないと、ガラパゴス(他に適応力ない)回答になる懸念も生じてしまう。
>VBAで対応しようということですから、高頻度で繰り返す処理なのだろうなぁとは思うのですが、
>その必要性に思いを至す状況を私は感じ取れないです。
今回のグループ分けの趣旨としてはグループ学習を行う際に成績、性格(ここではFFS理論を用いて4パターンに分類しています)、友人関係の3点をそれぞれ重視した場合どのような結果になるのかを出力しフィードバックをかけて3つの要素のバランスを図ることです。
なので、その第一段階として3つの要素のうちの1つである成績が均等になるようなグループ分けの処理を行っていました。
VBAやユーザーフォームを使用する必要がある理由は、高頻度で今後使う必要があるのも理由の1つですが、VBAやマクロが分からない先生方にも使用してもらうかもしてないからです。
まっつわんさん返事遅れてすみません!
>いまは順位を均等にする考えを提案していますが
はい。私も順位で均等にする方法で考えていました。
(misaki) 2016/10/17(月) 12:17
で、実行してみた結果はいかがなんでしょう?
(まっつわん) 2016/10/17(月) 12:35
更に難しいのが、友達関係で並べる場合。一人で沢山の生徒と紐付いている場合があれば、逆に殆ど相手が居ない場合もあるかと思います。それをどのように5人集めますか? どうなれば均等と呼べるのか、その考え方を教えてください。
例えば、15人分のご提示の例でも、A君は 2,3,8 が友達だとしていますが、3番目のC君以外は、1番目のA君を友達としていません。 こういう片思い関係も使いますか? それとも、両思いだけ一緒にして、あとはランダムに埋める、とか? 難しい条件は、もっと難しいコーディングが必要です。 何か研究論文にでもできそうな難しさを感じるのですが? 私には、どんなロジックならば友達関係を元にグループ分けできるのか、全然思いつきませんよ。
(片思いの場合、いじめ関係の可能性もあり得るので、逆に同じグループにしないほうが良かったり、とかありませんか?)
なんか、マクロで機械的に分けるより、8色の棒を5本ずつ用意して、皆で好きなのを取ってください、で良いように思います。 生徒自身で、友達と相談して色を合わせたり、嫌な相手を避けたりして、最適解になりそう。
(???) 2016/10/17(月) 13:39
まず、データの入ったシートのシートモジュールとして、以下を貼ってください。
これで、1行目の任意のセルを右クリックすると、その列を基準に昇順ソートできるようになります。
(出席番号でソートすれば、元に戻せます)
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Target.Row <> 1 Or Target.Rows.Count <> 1 Then Exit Sub
With Sort .SortFields.Clear .SortFields.Add _ Key:=Range(Cells(2, Target.Column), Cells(Cells(1, Target.Column).End(xlDown).Row, Target.Column)), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange Range("A1").CurrentRegion .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With
Cancel = True End Sub
次に、別のシートに、8グループ分の数式を埋めてください。例えば、以下のように、5人ずつ。
A2:=Sheet1!$A2
B2:=Sheet1!$A3
C2:=Sheet1!$A4
D2:=Sheet1!$A5
E2:=Sheet1!$A6
A4:=Sheet1!$A7
B4:=Sheet1!$A8
C4:=Sheet1!$A9
D4:=Sheet1!$A10
E4:=Sheet1!$A11
A6:=Sheet1!$A12
…
更に別のシートを用意して、縦横の関係が逆になるパターンを用意すれば、ドラフト案にもできます。(順位別用)
A2:=Sheet1!$A2
B2:=Sheet1!$A17
C2:=Sheet1!$A18
D2:=Sheet1!$A33
E2:=Sheet1!$A34
A4:=Sheet1!$A3
B4:=Sheet1!$A16
C4:=Sheet1!$A19
D4:=Sheet1!$A32
E4:=Sheet1!$A33
A6:=Sheet1!$A4
…
あとは、好きな列でソートするだけで、結果がいろいろ変わりますよ。
(???) 2016/10/17(月) 14:07
misakiさんからのレスがないですが、また疑問が出てしまったので書きます。
まっつわんさんの案が採用されたとして、8グループの氏名が書出されることになりますよね? その時、彼等の順位が平準化されていることはどうやって確かめますか?
多分、氏名をキーに各人の成績を検索し、RANK関数かなんかでその成績が 全成績の何位に相当するかを調べれば分かるんでしょうね。
それで「成績優先」は一件落着します。
・・で話を、第二・第三の段階である「性格優先」と「友達優先」の場合に進めます。
誰かの案で8グループの氏名が書出されることになりますよね? その時、各グループの性格構成とか、友達構成とかが平準化されていることはどうやって確かめますか? 今度はRANK関数を使うって訳にも行かないと思うんですけども。
もっとも「〇〇優先」って、全て「〇○を平準化させること」と解釈するのかどうかも そう明らかなじゃない気がしているんですが・・・
(半平太) 2016/10/18(火) 22:21
他にも、年少者にRFIDを1日中持たせて、時間毎の位置情報を得てデータ化。分析により近くにいた相手を友人として自動判断し、これを分布図にまとめ、範囲で括る、という手法も研究されているようです。
まぁ、誰がどう考えても、友人関係でぴったり8グループに分けるのは難しいわけですし、それをロジックとしてまとめるのはもっと大変な訳です。 なので、グループ分けは先生がテキトーに判断し、表は1列追加し、グループ番号を入力してはどうでしょうか。そして、グループ番号でソートすると、後は勝手にグループ分けした表になる、と。
(???) 2016/10/19(水) 09:57
>VBAやマクロが分からない先生方にも使用してもらうかもしてないからです。 ↑ かも知れないから と読み替え
適当にグループ分けするようなソフトでは、使ってもらった人に、 「このグループは本当に〇〇優先で分けられているの?」って聞かれた時、 チャンと答えられず、馬鹿にされると思いますけどねぇ。。
>グループ分けは先生がテキトーに判断し 自前で分けるシステムだとしても、どうテキトーに判断したのかは示せるようにしておかないと 後になったら、分けた本人だって思い出せなくなります。
そんないい加減な研究は、誰からも評価されないでしょう。 すると、この方法では誰も研究しない。
生徒たちはどんどん成長していくので、グループ分けの成果診断は更に難しそう。 こっちの方は、歴史的に積み上げてきたツールでもあるんでしょうかねぇ。。
(半平太) 2016/10/19(水) 10:44
第二・第三の段階である「性格優先」と「友達優先」の場合に進めます。 誰かの案で8グループの氏名が書出されることになりますよね? その時、各グループの性格構成とか、友達構成とかが平準化されていることはどうやって確かめますか? 今度はRANK関数を使うって訳にも行かないと思うんですけども。 もっとも「〇〇優先」って、全て「〇○を平準化させること」と解釈するのかどうかも そう明らかなじゃない気がしているんですが・・・
性格優先の場合は4パターンの性格が極力偏りが無いように班分けを行いたいと思っていました。理想は4種類すべての性格が同じくらいの人数になることですが、そのような事は奇跡に近い事だと思っているので、1種類の性格の生徒だけが固まってしまうということを避ける程度なら比較的実現が可能なのではと思っていました。
1番多い性格のタイプを8グループに割り振り→2番目に多い性格のタイプを8グループに割り振り→3番目に多い性格のタイプを8グループに割り振り→人数が足りないところに余りを足す
というロジックで考えていましたがもっと良い方法などはありますかね?
(misaki) 2016/10/19(水) 11:16
4つの性格それぞれ8つのグループに分けていって、余った分を調整、という考え方は、コンピュータのロジックを考えると、結構難しいです。その割にはドラフト方式の結果と大差ない、もしくは若いグループは後の性格が割り振られにくいという結果になるのではないかと思いますよ?
(???) 2016/10/19(水) 11:29
AAAAAAAA AA BBBBBBBB BB CCCCCCCC
Cのあと2名を続きに振って、残りをDで埋めると…。
AAAAAAAA AACCDDDD BBBBBBBB BBDDDDDD CCCCCCCC
このように、1,2グループにDが居ない状態になります。
ドラフト案の場合は、以下。
AAAAAAAA BBBBBBAA BBBBCCCC DDCCCCCC DDDDDDDD
うーん、1,2グループにCが居ないし、7,8グループにBが居ないか…。
折り返さずに埋めていくとか?
AAAAAAAA AABBBBBB BBBBCCCC CCCCCCDD DDDDDDDD
お、これならロジックも簡単だし、結構バラついていると言えるのでは?
(ロジック部分は、セル参照する別表で十分)
(???) 2016/10/19(水) 11:46
この案凄く素晴らしいと思います!!
これでまずはやってみようかと思います。
何か問題が発生した際には再度お助けしていただくことになるとは思いますが・・・。
でも、友人関係優先の班分けはやはり難しいですよね・・・。
単純な関係ではないので。
(misaki) 2016/10/19(水) 14:07
>でも、友人関係優先の班分けはやはり難しいですよね・・・。
これは、結果的にどんな組み合わせになっていると、優先していると判定されるんですか?
仲間同士がいっぱい集まったグループを多くすればいいのですのか?
それとも、仲間同士は出来るだけ組まないグループを多くすればいいのですか?
それとも、仲間の多寡は不問で、兎に角、全体的に同じような仲間の数で揃っていればいいのですか?
ところで、 1.友達って普通、お互いの関係だと思うのですが、片思い的はデータもあるんですか? 2.データは本当に3人分だけなんですか? 3.3人分はすべてデータで埋まっているんですか?
(半平太) 2016/10/19(水) 15:20
1 2 3 4 5 6 7 8 16 15 14 13 12 11 10 9 17 18 19 20 21 22 23 24 32 31 30 29 28 27 26 25 平均 16.5 16.5 16.5 16.5 16.5 16.5 16.5 16.5
>>でも、友人関係優先の班分けはやはり難しいですよね・・・。
全員の優先順位を作れば、何となく分けれませんかね?(ただの勘ですが。)
(ただ、仲良しグループを作ってもしょうがないので、
一緒にしてはいけない方を優先した方が個人的にはいいかなと思いますが。。。)
性格の場合は、
順番に配置するグループをずらしてとか・・・
1 2 3 4 5 6 7 8
A B C D A B C D
B C D A B C D A
C D A B C D A B
C A B C A C A C
A C A A A A A A
どうせ均等にはいないだろうから偏るのは必然ですよね?
(ここまで考察して、結局、「○○優先」なんてことが無意味に見えてくるのは
僕だけだろうか。。。。)
(まっつわん) 2016/10/19(水) 15:57
>2.データは本当に3人分だけなんですか?
>3.3人分はすべてデータで埋まっているんですか?
3人だけ書いてもらうようにしていますが、中には2人しか書いていない生徒だけでなく無記入の生徒もいて、アンケートを採った後日に話を聞いたところクラス内には友達がいないと正直に話してくれました。
(misaki) 2016/10/20(木) 10:29
こういうことを考えるのも面白いですが、
ロジックというのかアルゴリズムというのかよくわかりませんが、
解法は数学の掲示板の方がいいアドバイスがもらえるかなぁ。。。と、思わなくもありません。
そして、misakiさんが決めた方法で班分けをするとき、
エクセル的にはどうやればいいかをここで聞いたらいいと思います。
出席番号 名前 点数 性格分析 友達1 友達2 友達3
1 A 75 TG型 2 3 8
2 B 80 AN型 5 8 10
3 C 65 ML型 8 1 12
4 D 58 ML型 10 11 14
5 E 90 AN型 15 13 9
6 F 76 AN型 14 12 7
7 G 82 LM型 12 15 6
8 H 70 AN型 7 2 5
9 I 68 ML型 1 4 15
10 J 78 ML型 4 9 11
11 K 98 AN型 10 5 1
12 L 66 AN型 9 7 2
13 M 55 ML型 8 6 4
14 N 71 AN型 3 15 6
15 O 81 AN型 2 9 13
16 P
16人を4x4に分けたとして
これくらいでいいのですかねぇ。。。。
出席番号n=1から順に処理
n番がグループに配置されているか?
真なら配置されてない友達を同じグループに配置
偽なら友達のグループに配置
もし、友達も配置されてなければ
上左優先で配置し配置されてない友達も同じグループで配置
次へ
こんなロジックで、
G1 1 2 5 15
G2 3 8 7 12
G3 4 10 9 11
G4 6 14 13 16
こんな感じになりませんかねぇ。。。
待ってるだけじゃマクロ作っては貰えないかもですよ^^
(まっつわん) 2016/10/20(木) 17:26
> 結果的にどんな組み合わせになっていると、優先していると判定されるんですか? > > 仲間同士がいっぱい集まったグループを多くすればいいのですか? > それとも、仲間同士は出来るだけ組まないグループを多くすればいいのですか? > それとも、仲間の多寡は不問で、兎に角、全体的に同じような仲間の数で揃っていればいいのですか?
まだ上の疑問にお答えいただいてないんですが、どれなのですか?
misakiさんは自明に近いことなのかも知れないですけど、 こっちはそういう研究なんて考えたことすら無いレベルですから、全く分からないです。
今までの流れだと 優先=平準化 ですから、最後のものかなとも思いますが、 語感からすると、仲間同士を出来るだけ集めるのが自然だなぁとも思います。
でも勉強の促進と言う観点では仲良しクラブじゃダメと言うのも自分の経験から言えるんですよねぇ。(-_-;)
(半平太) 2016/10/20(木) 18:24
「仲良しクラブ」と解釈してみます。
緻密にやろうとするとかなり厄介と思われました。 そこで、以下のロジックにしてみました。
1.友達がチャンと3人いる生徒をテキトーに8人選んで、各グループのリーダーとする。 2.各グループを昇順にみて行き、リーダーの友達の中でまだ選ばれていない生徒が居たら、その人を2人目にする(※)。 3.各グループを降順にみて行き、「リーダー 〜 2人目」の友達の中でまだ選ばれていない生徒が居たら、その人を3人目にする(※)。 4.各グループを昇順にみて行き、「リーダー 〜 3人目」の友達の中でまだ選ばれていない生徒が居たら、その人を4人目にする(※)。 5.各グループを降順にみて行き、「リーダー 〜 4人目」の友達の中でまだ選ばれていない生徒が居たら、その人を5人目にする(※)
(※)友達が既に全員選ばれていたら、残生徒からテキトーに新メンバーを決める。
テキトーに選んでいるので、いい時も、ダメな時もありますので、 100回トライさせて、その中で一番よかったのを採用する。
※何を以てよかったと判定するかは、単純な話ではなく、悩ましいのですが、 下案は、同じグループに友達が含まれている数の多寡で単純に判定させております。
使い方は、J2、J3、J4セルのどれかを右クリックするだけです。
<Sheet1> 行 ____A____ __B__ __C__ ____D____ ___E___ __F__ __G__ _H_ _I_ _____J_____ _K_ _L_ _M_ _N_ _O_ _P_ ____Q____ ____R____ ___S___ 1 出席番号 名前 点数 性格分析 友達1 友達2 友達3 右CLICK指定 平均順位 性格自乗 友達数 2 1 NM01 75 TG型 2 3 8 成績優先 1 29 22 4 31 25 19.4 7 5 3 2 NM02 80 AN型 5 8 10 性格優先 2 11 5 15 21 24 7.4 17 4 4 3 NM03 65 ML型 8 1 12 友達優先 3 13 8 2 17 30 28.4 17 5 5 4 NM04 58 ML型 10 11 14 4 36 12 9 10 23 20.2 13 5 6 5 NM05 90 AN型 15 13 9 5 19 18 32 33 34 24.8 17 6 7 6 NM06 76 AN型 14 12 7 6 26 16 35 38 27 19.6 17 5 8 7 NM07 82 LM型 12 15 6 7 14 3 6 7 37 23.8 9 6 9 8 NM08 70 AN型 18 2 5 8 40 1 20 28 39 17 11 6 10 9 NM09 68 ML型 1 4 15 5.877021 13.5 42 11 10 NM10 78 ML型 4 9 11 標準偏差 自乗平均 合計 12 11 NM11 98 AN型 12 5 1
’構造体を利用したのですが、却って分かりにくくなったかも知れません。
1.Sheet1のシートモジュールに
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("J2:J4")) Is Nothing Then Exit Sub ElseIf Intersect(Target, Range("J2:J4")).Count <> 1 Then Exit Sub Else Cancel = True
Range("Q1").Value = "平均順位" Range("R1").Value = "性格自乗" Range("S1").Value = "友達数" Range("Q11").Value = "標準偏差" Range("R11").Value = "自乗平均" Range("S11").Value = "合計"
Range("Q10").FormulaR1C1Local = "=STDEVP(R[-8]C:R[-1]C)" Range("R10").FormulaR1C1Local = "=AVERAGE(R[-8]C:R[-1]C)" Range("S10").FormulaR1C1Local = "=SUM(R[-8]C:R[-1]C)"
Range("J2:J4,Q1:S1,Q11:S11").Interior.Color = xlNone Target.Interior.Color = 65535
Cells(1, CLng(Right(Target.Address, 1)) + 15).Interior.Color = 65535 Cells(11, CLng(Right(Target.Address, 1)) + 15).Interior.Color = 65535
Call Grouping(CLng(Right(Target.Address, 1)) - 1)
End If End Sub
2.標準モジュールに
Type Stutent
TS出席 As Long TS名前 As String TS点数 As Double TS性格 As String TS友達(1 To 3) As Double TS順位 As Long End Type
Type Group
TG順位合計 As Double TG型別Ary(1 To 4) As Integer '同じ性格の個数 TG友数Ary(1 To 5) As Integer '各人から数えた、同じグループ内の友達の数 TGstudentIDs(1 To 5) As Long TGavrg順位 As Double TGsqure性格 As Double TGsum友達 As Double End Type
Sub Grouping(優先No As Long)
Dim DicT As Object Dim GRPs(1 To 8) As Group Dim Students(1 To 40) As Stutent
Dim IdOrderByPform Dim IdOrderByFriends
Dim rngVALs Dim NN As Long, KK As Long, trialNO As Long
Dim 性格型Ary Dim a性格
Dim numToPick As Long Dim Mnum As Long, Gnum
Dim OneLeaderID As Long Dim TopID As Long Dim NextID As Long Dim draftOrder
Dim aSetOf5Gs, bestSetOf5Gs Dim thisScore As Double, bestScore As Double
性格型Ary = Array("TG型", "AN型", "ML型", "LM型")
Rem 全データをStudent構造体の配列に格納 With Sheets("Sheet1") rngVALs = .Range("A2:G41").Value
For NN = 1 To 40 Students(NN).TS出席 = rngVALs(NN, 1) Students(NN).TS名前 = rngVALs(NN, 2) Students(NN).TS点数 = rngVALs(NN, 3) Students(NN).TS性格 = rngVALs(NN, 4) Students(NN).TS友達(1) = rngVALs(NN, 5) Students(NN).TS友達(2) = rngVALs(NN, 6) Students(NN).TS友達(3) = rngVALs(NN, 7) Students(NN).TS順位 = Application.Rank(rngVALs(NN, 3), .Range("C2:C41")) Next NN End With
Select Case 優先No '1成績、2性格、3友達 Case 1 'まっつわん方式
'成績順に出席番号(ID)を取得 IdOrderByPform = _ Sheets("Sheet1").[INDEX(mod(SMALL(RANK(C2:C41,C2:C41)*1000+ROW(C1:C40),ROW(C1:C40)),1000),0)]
ReDim aSetOf5Gs(1 To 40) KK = 0 For Mnum = 1 To 5 draftOrder = IIf(Mnum Mod 2, [{1,2,3,4,5,6,7,8}], [{8,7,6,5,4,3,2,1}])
For Each Gnum In draftOrder KK = KK + 1 aSetOf5Gs((Gnum - 1) * 5 + Mnum) = IdOrderByPform(KK, 1) Next Next Mnum
Call make5GpsMatrix(aSetOf5Gs, Students, GRPs, 性格型Ary) '2次元の表に変換する
Case 2 '???方式 ReDim aSetOf5Gs(1 To 40)
For Each a性格 In 性格型Ary '各性格型毎に処理 For NN = 1 To 40 'IDを1〜40、性格型の数(4回)分処理する If Students(NN).TS性格 = a性格 Then '性格型が合致したら numToPick = numToPick + 1 '何個目? Gnum = (numToPick - 1) Mod 8 '一つ前のグループ番号 Mnum = Int((numToPick + 7) / 8) 'メンバー順 aSetOf5Gs(Gnum * 5 + Mnum) = NN '該当位置にIDを配置して行く End If Next NN Next
Call make5GpsMatrix(aSetOf5Gs, Students, GRPs, 性格型Ary) '2次元の表に変換する
Case 3 '仲良しクラブ bestScore = 0 bestSetOf5Gs = Empty For trialNO = 1 To 100
ReDim aSetOf5Gs(1 To 40)
'友達が多い方を頭に出席番号を並べる IdOrderByFriends = _ Sheets("Sheet1").[index(41-MOD(LARGE(MMULT(ISNUMBER(E2:G41)*1000+41-ROW(A1:A40),{1;1;1}),ROW(A1:A40)),1000)/3,0)]
Set DicT = CreateObject("Scripting.Dictionary") '上の順でディクショナリに全IDを登録 For NN = 1 To 40 DicT(IdOrderByFriends(NN, 1)) = Empty Next NN
Rem リーダーを決定する Gnum = 0 Do Until Gnum = 8 OneLeaderID = Application.RandBetween(1, 40)
'リーダーは友達が3人いなければならない If Application.Count(Students(IdOrderByFriends(OneLeaderID, 1)).TS友達) = 3 Then If DicT.exists(OneLeaderID) Then
Gnum = Gnum + 1 GRPs(Gnum).TGstudentIDs(1) = OneLeaderID 'グループのリーダーを決定 DicT.Remove OneLeaderID 'DicTから抹消 aSetOf5Gs((Gnum - 1) * 5 + 1) = OneLeaderID '該当位置にIDを配置して行く End If End If
Loop
Rem 2人目以降を決定する
For Mnum = 2 To 5 '2人目以降を決定する draftOrder = IIf(Mnum Mod 2, [{1,2,3,4,5,6,7,8}], [{8,7,6,5,4,3,2,1}]) For Each Gnum In draftOrder NextID = getNextID(GRPs, Gnum, DicT, Students) 'X人目のIDを取得
If NextID = 99 Then '99→友無し。登録IDから一人取出して、X人目のIDとする TopID = Application.Index(DicT.keys, 1) GRPs(Gnum).TGstudentIDs(Mnum) = TopID DicT.Remove TopID 'DicTから抹消 aSetOf5Gs((Gnum - 1) * 5 + Mnum) = TopID '該当位置にIDを配置して行く
Else GRPs(Gnum).TGstudentIDs(Mnum) = NextID DicT.Remove NextID 'DicTから抹消 aSetOf5Gs((Gnum - 1) * 5 + Mnum) = NextID '該当位置にIDを配置して行く
End If
Next Next Mnum
Call make5GpsMatrix(aSetOf5Gs, Students, GRPs, 性格型Ary) '2次元の表に変換する
For Gnum = 1 To 8 thisScore = thisScore + Application.Sum(GRPs(Gnum).TG友数Ary) Next Gnum
If thisScore > bestScore Then bestScore = thisScore bestSetOf5Gs = aSetOf5Gs End If
Erase GRPs thisScore = 0 Next trialNO
Call make5GpsMatrix(bestSetOf5Gs, Students, GRPs, 性格型Ary) '2次元の表に変換する End Select
'結果打ち出し Call printResult(Students, GRPs)
End Sub
Function getNextID(GRPs() As Group, Gnum, DicT As Object, Students() As Stutent) As Long
Dim Mnum, mateOrder As Long, 友ID As Long, MemId As Long Dim draftOrder
getNextID = 99 '各メンバーに全然友達が残っていない場合は初期値「99」を返す
draftOrder = IIf(Mnum Mod 2, [{1,2,3,4,5}], [{5,4,3,2,1}])
For Each Mnum In draftOrder 'メンバーをトップ(またはボトム)から順次チェック MemId = GRPs(Gnum).TGstudentIDs(Mnum) '各グループメンバーのIDを順次取得 If MemId > 0 Then For mateOrder = 1 To 3 'そのメンバーの友達IDを順次調べる 友ID = Students(MemId).TS友達(mateOrder) If DicT.exists(友ID) Then getNextID = 友ID '新しいメンバーを決定 Exit Function End If Next mateOrder End If Next
End Function
Sub make5GpsMatrix(aSetOf5Gs, Students() As Stutent, GRPs() As Group, 性格型Ary)
Dim IDpos As Long Dim GRnum As Long, GmemNum As Long Dim aryAvrgForAses(1 To 5), i As Long Dim 性格型Pos As Integer
IDpos = 0
For GRnum = 1 To 8 For GmemNum = 1 To 5
IDpos = IDpos + 1
GRPs(GRnum).TGstudentIDs(GmemNum) = aSetOf5Gs(IDpos) 'IDの並びを頭から取出し
'同人の性格を調べて、型別にカウントして行く 性格型Pos = Application.Match(Students(aSetOf5Gs(IDpos)).TS性格, 性格型Ary, 0) GRPs(GRnum).TG型別Ary(性格型Pos) = GRPs(GRnum).TG型別Ary(性格型Pos) + 1
GRPs(GRnum).TG順位合計 = GRPs(GRnum).TG順位合計 + Students(aSetOf5Gs(IDpos)).TS順位
Next GmemNum
Call analyOneGroup(GRnum, GRPs, Students)
Next GRnum End Sub
Sub analyOneGroup(GRnum As Long, GRPs() As Group, Students() As Stutent) 'グループの分析
Dim Mnum As Long, KK As Long, MateID As Long Dim MateFrndID As Long, numFriends As Long
For Mnum = 1 To 5 '個々人のグループ内友達数を相互カウント MateID = GRPs(GRnum).TGstudentIDs(Mnum) numFriends = 0
For KK = 1 To 3
MateFrndID = Students(MateID).TS友達(KK)
If IsNumeric(Application.Match(MateFrndID, GRPs(GRnum).TGstudentIDs, 0)) Then numFriends = numFriends + 1 End If
Next KK
GRPs(GRnum).TG友数Ary(Mnum) = numFriends
Next Mnum
GRPs(GRnum).TGavrg順位 = GRPs(GRnum).TG順位合計 / 5 '平均順位算出 GRPs(GRnum).TGsqure性格 = Application.SumProduct(GRPs(GRnum).TG型別Ary, GRPs(GRnum).TG型別Ary) '性格自乗 GRPs(GRnum).TGsum友達 = Application.Sum(GRPs(GRnum).TG友数Ary) '友達数合計
End Sub
Sub printResult(Students() As Stutent, GRPs() As Group)
Dim NN As Long, LL As Long
With Sheets("Sheet1") For NN = 1 To UBound(GRPs) .Cells(NN + 1, "K") = NN .Cells(NN + 1, "Q") = GRPs(NN).TGavrg順位 .Cells(NN + 1, "R") = GRPs(NN).TGsqure性格 .Cells(NN + 1, "S") = GRPs(NN).TGsum友達
' .Cells(NN + 1, "U").Resize(1, 4) = GRPs(NN).TG型別Ary ' .Cells(NN + 1, "Z").Resize(1, 5) = GRPs(NN).TG友数Ary
For LL = 1 To 5 .Cells(NN + 1, 11 + LL) = GRPs(NN).TGstudentIDs(LL) Next LL
Next NN End With End Sub
(半平太) 2016/10/21(金) 20:47
上記コードに修正を加えました。
※Case1とCase2の冗長性を排除した為。 これにより「mattuwan3INaRow」は不要化したので、削除しました。
(半平太) 2016/10/22(土) 21:02
アドバイスありがとうございます。
>結果的にどんな組み合わせになっていると、優先していると判定されるんですか? > 仲間同士がいっぱい集まったグループを多くすればいいのですか? > それとも、仲間同士は出来るだけ組まないグループを多くすればいいのですか? > それとも、仲間の多寡は不問で、兎に角、全体的に同じような仲間の数で揃っていればいいのですか?
今現在では仲間がいっぱい集まったグループを多く作る事を考えていました。
お待たせさせてしまいすみません。
半平太さんのコード参考にさせていただきます
(misaki) 2016/10/25(火) 11:22
・友人指定されている番号毎に集計し、指定数の多い順でソートする。
・データから、お互いに相手の番号を入れているペアを見つける。これを指定数の多い順で、それぞれのグループに入れる。
・ペアの数が多い場合は8組で切る。足りない場合は、指定数の多い順で埋める。
・ここまで決まった生徒の番号を指定している人を、それぞれのグループに埋めていく。
・残った人を、空いたグループに埋めて完成。
両思い状態のペアは、同じグループに入れたいというところが肝です。
(???) 2016/10/25(火) 11:47
Students(NN).TS順位 = Application.Rank(rngVALs(NN, 3), .Range("C2:C41"))
の部分で型が一致しないというエラーが出てしまいます。こういった場合はどのような対処をすれば良いのでしょうか?
>両思い状態のペアは、同じグループに入れたいというところが肝です。
このような場合だと、両者とも友達が多い場合に凄く困るような気がしています。ばらばらにした方が上手くいくのではないかなと私は思っていました。
(misaki) 2016/10/25(火) 13:37
>Students(NN).TS順位 = Application.Rank(rngVALs(NN, 3), .Range("C2:C41")) >の部分で型が一致しないというエラーが出てしまいます。 >こういった場合はどのような対処をすれば良いのでしょうか?
出席番号がNN番の生徒の成績が入力されていないと言うことだと思います
データは40人分漏れなく入力されているという前提です。(ただし、友達の欄だけは未入力も可)
(半平太) 2016/10/25(火) 14:18
なるほど!実行したらエラーがなくなりました!
(misaki) 2016/10/26(水) 10:52
この3つの要素を組み合わせて(割合を自由に変化させて)結果の出力を行うということは可能なのでしょうか?
別のシートでもいいので、このようなことが出来るようになると更に授業ごとのグループ分けのニーズにこたえることが出来ると思うので、考えてみたのですがロジックから思いつかなかったので、どなたか助けてください!!!
(misaki) 2016/12/20(火) 11:11
ロジックなりアルゴリズムなりを知りたかったら、
まずは数学の掲示板で聞いて見てはいかがでしょうか?
それがわかったら、VBAのコードに翻訳する部分をここで相談してみてはいかがでしょうか?
>(割合を自由に変化させて)
こんなことが数学的に表現できるとは思えないですが。。。
結果的に、無作為に並べたのと違いがあると言えるのですかね。。。。
(まっつわん) 2016/12/20(火) 12:50
無作為で並べてみて、
どのようになってたら意図に近いか評価して、
だめなら、また並べなおして、評価。
を繰り返す方が、たぶん考え方が簡単かなと思います。
(まっつわん) 2016/12/20(火) 17:44
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.