【会員アンケートご協力のお願い】抽選で計5名様に役立つ書籍をプレゼント!
Excel (VBA) |
|
(Windows 10全般 : 指定なし)
各メンバーの点数の合計をできるだけ均等にするようなグループ分けの方法について
投稿日時: 24/08/28 09:52:45
投稿者: simple
|
---|---|
「各人の持っているポイントをもとに、
A列 B列 1行 ID POINT 2 1005 12 3 1007 15 4 1009 6 5 1010 13 6 1018 21 7 1022 8 8 1027 9 9 1028 13 10 1029 11 11 1030 7 12 1042 18 13 1049 4 14 1050 8 15 1053 17 16 1056 20 17 1061 13 18 1065 5 19 1069 22 20 1071 1 21 1079 5 22 1080 7 23 1082 10 24 1089 21 25 1093 8 <結果>(私の提示するコードによるもの) ID POINT ID POINT ID POINT 合計 平均 1組 1071 1 1028 13 1018 21 35 11.66666667 2組 1049 4 1050 8 1069 22 34 11.33333333 3組 1082 10 1029 11 1061 13 34 11.33333333 4組 1065 5 1093 8 1089 21 34 11.33333333 5組 1027 9 1030 7 1042 18 34 11.33333333 6組 1079 5 1010 13 1053 17 35 11.66666667 7組 1009 6 1022 8 1056 20 34 11.33333333 8組 1080 7 1005 12 1007 15 34 11.33333333 (■例2) 100人を1グループ4人の25グループに分けるケース <Sheet1>元データ (平均50、標準偏差10の正規分布に従った乱数例) (スペース節約のため三段書きにしていますが、A,B列だけです。) A列 B列 A列 B列 A列 B列 ID POINT m34 65 m67 46 m1 54 m35 44 m68 49 m2 53 m36 44 m69 52 m3 42 m37 50 m70 50 m4 46 m38 53 m71 40 m5 42 m39 45 m72 33 m6 45 m40 53 m73 51 m7 50 m41 64 m74 39 m8 48 m42 59 m75 51 m9 30 m43 58 m76 46 m10 56 m44 59 m77 48 m11 52 m45 56 m78 61 m12 58 m46 52 m79 49 m13 56 m47 62 m80 45 m14 44 m48 55 m81 41 m15 48 m49 44 m82 58 m16 56 m50 30 m83 22 m17 48 m51 27 m84 46 m18 64 m52 63 m85 28 m19 57 m53 33 m86 61 m20 63 m54 34 m87 61 m21 61 m55 37 m88 54 m22 40 m56 55 m89 49 m23 45 m57 53 m90 52 m24 57 m58 48 m91 62 m25 41 m59 60 m92 47 m26 43 m60 47 m93 40 m27 50 m61 67 m94 38 m28 55 m62 56 m95 52 m29 43 m63 46 m96 47 m30 51 m64 57 m97 47 m31 48 m65 60 m98 26 m32 62 m66 52 m99 52 m33 44 m100 43 <結果>(同上) ID POINT ID POINT ID POINT ID POINT 合計 平均 1組 m98 26 m13 56 m78 61 m88 54 197 49.25 2組 m83 22 m91 62 m70 50 m20 63 197 49.25 3組 m14 44 m36 44 m8 48 m87 61 197 49.25 4組 m35 44 m68 49 m66 52 m46 52 197 49.25 5組 m37 50 m17 48 m76 46 m2 53 197 49.25 6組 m55 37 m27 50 m7 50 m65 60 197 49.25 7組 m54 34 m96 47 m89 49 m61 67 197 49.25 8組 m97 47 m51 27 m32 62 m21 61 197 49.25 9組 m81 41 m80 45 m63 46 m34 65 197 49.25 10組 m85 28 m40 53 m95 52 m41 64 197 49.25 11組 m29 43 m84 46 m64 57 m30 51 197 49.25 12組 m9 30 m90 52 m24 57 m43 58 197 49.25 13組 m100 43 m11 52 m33 44 m82 58 197 49.25 14組 m26 43 m39 45 m15 48 m86 61 197 49.25 15組 m4 46 m79 49 m49 44 m44 59 198 49.5 16組 m53 33 m75 51 m57 53 m59 60 197 49.25 17組 m71 40 m3 42 m38 53 m47 62 197 49.25 18組 m25 41 m67 46 m1 54 m45 56 197 49.25 19組 m50 30 m69 52 m10 56 m42 59 197 49.25 20組 m22 40 m94 38 m16 56 m52 63 197 49.25 21組 m5 42 m31 48 m99 52 m48 55 197 49.25 22組 m93 40 m58 48 m73 51 m12 58 197 49.25 23組 m74 39 m92 47 m28 55 m62 56 197 49.25 24組 m72 33 m23 45 m56 55 m18 64 197 49.25 25組 m6 45 m77 48 m60 47 m19 57 197 49.25 ちなみに、同じデータを用いたskさんのコードによる結果は次のようでした。 (各組の要約部分のみ引用させていただきます。IDは整数に変更して実行しました) (1) 24人を1グループ3人の8グループに分けるケース 組 人数 人数上限 POINT合計 POINT平均 1 3 3 34 11.33333333 2 3 3 34 11.33333333 3 3 3 34 11.33333333 4 3 3 35 11.66666667 5 3 3 36 12 6 3 3 32 10.66666667 7 3 3 35 11.66666667 8 3 3 34 11.33333333 (2)100人を1グループ4人の25グループに分けるケース 組 人数 人数上限 POINT合計 POINT平均 1 4 4 180 45 2 4 4 183 45.75 3 4 4 186 46.5 4 4 4 190 47.5 5 4 4 194 48.5 6 4 4 197 49.25 7 4 4 197 49.25 8 4 4 197 49.25 9 4 4 197 49.25 10 4 4 197 49.25 11 4 4 197 49.25 12 4 4 197 49.25 13 4 4 197 49.25 14 4 4 197 49.25 15 4 4 197 49.25 16 4 4 197 49.25 17 4 4 197 49.25 18 4 4 197 49.25 19 4 4 197 49.25 20 4 4 199 49.75 21 4 4 200 50 22 4 4 204 51 23 4 4 210 52.5 24 4 4 210 52.5 25 4 4 212 53 |
投稿日時: 24/08/28 09:56:16
投稿者: simple
|
|
---|---|
続いて、VBAコードを書きます。
Option Explicit Const maxIterations As Long = 5 '繰返し回数。100人くらいならこの程度でよさそう。 Dim numOfgroupMembers As Long '一組のメンバーの人数 Dim groupAry() As Variant Sub main() numOfgroupMembers = 3 '■要修正 ' numOfgroupMembers = 4 '■要修正 Dim numOfAllMembers As Long 'メンバーの総人数 Dim numOfGroups As Long '組の数 Dim scores As Variant Dim totalPoint& Dim iter& Dim i&, j&, k& Dim g1&, g2&, m1& Dim t t = Timer With ThisWorkbook.Worksheets(1) numOfAllMembers = .Cells(Rows.Count, "A").End(xlUp).Row - 1 If (numOfAllMembers Mod numOfgroupMembers) <> 0 Then MsgBox "メンバーの総数" & numOfAllMembers & "は、 " & numOfgroupMembers _ & " で割り切れる数にして下さい。" & vbLf _ & "一旦終了します" Exit Sub End If numOfGroups = numOfAllMembers / numOfgroupMembers .Range("A1").CurrentRegion.Copy .Range("D1").PasteSpecial Paste:=xlPasteValues Application.Goto .Range("A1") '点数の昇順でいったんソート .Columns("D:E").Sort key1:=.Range("E2"), order1:=xlAscending, Header:=xlYes scores = .Range("D2").Resize(numOfAllMembers, 2).Value .Columns("D:E").ClearContents End With ' グループメンバーをいったん仮決め--------------------------------------- ReDim groupAry(1 To numOfGroups, 1 To numOfgroupMembers) As Variant 'ジャグ配列 ' グループにIDと点数を仮に割り当てる For k = 1 To numOfAllMembers j = Int((k - 1) / numOfGroups) + 1 i = (k - 1) Mod numOfGroups + 1 groupAry(i, j) = Array(scores(k, 1), scores(k, 2)) 'ID,Pointからなる配列を要素 Next ' 各グループのPOINT合計を均すように修正--------------------------------------- For iter = 1 To maxIterations For g1 = 1 To numOfGroups ' For m1 = 1 To numOfgroupMembers For g2 = 1 To numOfGroups If g1 <> g2 Then 'g1組のm1番目の人とg2組の各人とを比較し、 '交換して両者の合計点の差が縮まるようなら交換する If trySwap(g1, m1, g2, numOfgroupMembers) Then Exit For End If Next Next Next Next '結果を新規ブックに書き込む ---------------------------------------------- With Workbooks.Add.Worksheets(1) '見出し For k = 1 To numOfGroups .Cells(k + 1, "A") = k & "組" Next For k = 1 To numOfgroupMembers .Cells(1, (k - 1) * 2 + 2) = "ID" .Cells(1, (k - 1) * 2 + 3) = "POINT" Next .Cells(1, numOfgroupMembers * 2 + 2).Value = "合計" .Cells(1, numOfgroupMembers * 2 + 3).Value = "平均" 'グループ組成結果 For i = 1 To numOfGroups For j = 1 To numOfgroupMembers .Cells(i + 1, j * 2).Value = groupAry(i, j)(0) ' ID .Cells(i + 1, j * 2 + 1).Value = groupAry(i, j)(1) ' 点数 Next totalPoint = GroupTotal(i) .Cells(i + 1, numOfgroupMembers * 2 + 2).Value = totalPoint ' 合計値 .Cells(i + 1, numOfgroupMembers * 2 + 3).Value = _ totalPoint / numOfgroupMembers ' 平均値 Next End With Debug.Print Timer - t MsgBox "終了" End Sub ' 点数の交換をトライ Function trySwap(ByVal g1 As Long, ByVal m1 As Long, _ ByVal g2 As Long, ByVal size As Long) As Boolean Dim score1 As Long Dim score2 As Long Dim temp As Variant Dim m2 As Long Dim t1 As Long Dim t2 As Long t1 = GroupTotal(g1) t2 = GroupTotal(g2) score1 = groupAry(g1, m1)(1) For m2 = 1 To size score2 = groupAry(g2, m2)(1) '交換後の合計の差が縮むなら交換する If Abs((t1 - score1 + score2) - (t2 - score2 + score1)) < Abs(t1 - t2) Then ' 交換 temp = groupAry(g1, m1) groupAry(g1, m1) = groupAry(g2, m2) groupAry(g2, m2) = temp trySwap = True Exit Function End If Next trySwap = False End Function ' g番目のグループの合計点数を計算する関数 Function GroupTotal(g As Long) As Long Dim k As Long Dim total As Long total = 0 For k = 1 To numOfgroupMembers total = total + groupAry(g, k)(1) Next GroupTotal = total End Function |
投稿日時: 24/08/29 10:37:42
投稿者: simple
|
|
---|---|
skさんから当方の発言へのコメントをいただきました。ありがとうございます。
|
投稿日時: 24/08/29 11:14:25
投稿者: sk
|
|
---|---|
引用: 件のスレッドでの回答は simple さんに宛てたものではありません。 |
投稿日時: 24/08/29 11:27:09
投稿者: simple
|
|
---|---|
そうでしたか、了解しました。 |