[[20161013141454]] 『VBAでグループ分け』(misaki) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『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


> 私のテストデータでやってみると、あまり平準化されていなかったです。
> 理由を考えてみたのですが、例えばトップが突出していい点だとすると、
> ワーストの1人だけじゃなく、ワースト2、下手すればワースト3も
> トップと組ませなくてはならない、と言う状況があるためだと思われます。
あぁ、テストの点でいくとそうなりますねー

順位で単純に振り分けてますもんねー

テストの平均点を揃える方向だと、
も少し複雑に選ばないとだめですねー

(まっつわん) 2016/10/14(金) 16:02


 まっつわんさん

 済みません。これを考慮していなかったです
        ↓
 >一番左のシートのA1:A40に成績順に名前が並んでいるとして

 再テストしたところ、十分リーズナブルな結果になっていました。

 ご容赦を・・ m(__)m

(半平太) 2016/10/14(金) 17:02


>再テストしたところ、十分リーズナブルな結果になっていました。
了解です。確認ありがとうございます。

(とはいえ、質問者の方の返事がないですねぇ。。。。)
(まっつわん) 2016/10/14(金) 17:14


いまは順位を均等にする考えを提案していますが、点数を均等にしようとすると、組合せが膨大な、カッティングストック問題になりますからね。 misakiさんがどこまで踏み込むつもりか、知りたいところ。
(???) 2016/10/14(金) 17:21

返事遅れてすみません!

>その、なかなかうまくいかない、という状態のコードを貼ってください。元が判らないと、何をアドバイスすれば良いのか判りませんので。
なかなか上手くいかないという表現が悪かったですね。どうすればいいのか分からないのほうが適切でしたすみません。

>あと、元データのレイアウトが判る実例も挙げてください。

          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


性格を4つに分類、との事ですが、グループは8つ。2グループに8人…とぴったり収まるなら良いですが、きっとバラついてますよね? それをどのように並べたいですか? 処理が簡単なのは、性格の文字列を元にソートして、上から順に5人ずつ代入していく方法でしょうか。これくらいなら書けますが、まず4グループは先頭からにして、残りを他から…、とか言わないように願います。ご自分で、どういうロジックならばそれが実現できるか、考えてみてください。
(同じ性格ばかり集めない方が良い、とかいう場合はありませんか? 他人任せばかり5人集めても、何も達成できなそう)

更に難しいのが、友達関係で並べる場合。一人で沢山の生徒と紐付いている場合があれば、逆に殆ど相手が居ない場合もあるかと思います。それをどのように5人集めますか? どうなれば均等と呼べるのか、その考え方を教えてください。

例えば、15人分のご提示の例でも、A君は 2,3,8 が友達だとしていますが、3番目のC君以外は、1番目のA君を友達としていません。 こういう片思い関係も使いますか? それとも、両思いだけ一緒にして、あとはランダムに埋める、とか? 難しい条件は、もっと難しいコーディングが必要です。 何か研究論文にでもできそうな難しさを感じるのですが? 私には、どんなロジックならば友達関係を元にグループ分けできるのか、全然思いつきませんよ。
(片思いの場合、いじめ関係の可能性もあり得るので、逆に同じグループにしないほうが良かったり、とかありませんか?)

なんか、マクロで機械的に分けるより、8色の棒を5本ずつ用意して、皆で好きなのを取ってください、で良いように思います。 生徒自身で、友達と相談して色を合わせたり、嫌な相手を避けたりして、最適解になりそう。
(???) 2016/10/17(月) 13:39


友達関係をよく見ると、自分自身を入れているケースがありますねぇ。寂しい…。
まぁ、適当に入れた数字であり、実際とは全く異なるのだろう、とは思いますが。
(???) 2016/10/17(月) 13:43

1つの汎用案なぞ。

まず、データの入ったシートのシートモジュールとして、以下を貼ってください。
これで、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


探してみると、Lineのグループ所属情報を聞き出して、これを元に関係図を描く案が、研究論文発表されてました。
実データを集めやすくて、現代的で面白い考え方ですね。 直接友人名を入力させる訳では無いので、本音のデータが得られそうです。
http://ci.nii.ac.jp/naid/110010040429

他にも、年少者に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


片寄る例。4つの性格をABCDで表現。それぞれ10人ずつ居る場合。(横がグループ、縦が5名と見てください)
misakiさんの考えている方法は、こうですかね? 1グループ目からそれぞれ割り振ると、まず以下の状態になります。
 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


> まっつわんさんの案が採用されたとして、8グループの氏名が書出されることになりますよね?
> その時、彼等の順位が平準化されていることはどうやって確かめますか?
1グループが偶数人数のときは一応順位を点数と考えれば、各グループが同じになります。

	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


>1.友達って普通、お互いの関係だと思うのですが、片思い的はデータもあるんですか?
片思い的なデータもあります。特に仲の良い友達3人を挙げるとしたら誰ですか?という質問なので、本当に片思いなのかは不明ですが。(仲が悪いわけではないけど、凄く仲が良いとは思っていないというような状況は誰でもありうることだと思いますし。)

>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さんが決めた方法で班分けをするとき、
>エクセル的にはどうやればいいかをここで聞いたらいいと思います。

アドバイスありがとうございます。

 >結果的にどんな組み合わせになっていると、優先していると判定されるんですか?
 > 仲間同士がいっぱい集まったグループを多くすればいいのですか?
 > それとも、仲間同士は出来るだけ組まないグループを多くすればいいのですか?
 > それとも、仲間の多寡は不問で、兎に角、全体的に同じような仲間の数で揃っていればいいのですか?

今現在では仲間がいっぱい集まったグループを多く作る事を考えていました。
お待たせさせてしまいすみません。
半平太さんのコード参考にさせていただきます
(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


>出席番号がNN番の生徒の成績が入力されていないと言うことだと思います
>データは40人分漏れなく入力されているという前提です。(ただし、友達の欄だけは未入力も可)

なるほど!実行したらエラーがなくなりました!
(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.