Excel (VBA) |
|
(指定なし : 指定なし)
各組合計値の平均でグループ分け
投稿日時: 24/08/23 09:31:05
投稿者: tako552101
|
---|---|
お世話になります。Win10 ver2010です。
|
投稿日時: 24/08/23 10:19:21
投稿者: Suzu
|
|
---|---|
いきなりデータを、列ごとに移動しないとダメですか?
A B C D E F G 1 ID POINT 組 274 91.33333333 2 1069 22 A 0 0 3 1018 21 B 0 0 4 1089 21 C 0 0 5 1056 20 6 1042 18 7 1053 17 8 1007 15 9 1010 13 10 1028 13 11 1061 13 12 1005 12 13 1029 11 14 1082 10 15 1027 9 16 1022 8 17 1050 8 18 1093 8 19 1030 7 20 1080 7 21 1009 6 22 1065 5 23 1079 5 24 1049 4 25 1071 1 ここまでやったら、 C2〜C7 にABCABC を入れ、オートフィル A B C D E F G 1 ID POINT 組 274 91.33333333 2 1069 22 A A 100 8 3 1018 21 B B 91 8 4 1089 21 C C 83 8 5 1056 20 A 6 1042 18 B 7 1053 17 C 8 1007 15 A 9 1010 13 B 10 1028 13 C 11 1061 13 A 12 1005 12 B 13 1029 11 C 14 1082 10 A 15 1027 9 B 16 1022 8 C 17 1050 8 A 18 1093 8 B 19 1030 7 C 20 1080 7 A 21 1009 6 B 22 1065 5 C 23 1079 5 A 24 1049 4 B 25 1071 1 C 平均値、91.333・・に対し G2〜G4の A〜C の合計値、から、Aが高く、Cが低いのが読み取れますから、 C2を A→C、C4をC→A まだ、Aが高いので C5を A→C、C7をC→A : と調整し 最終的に A B C D E F G 1 ID POINT 組 274 91.33333333 2 1069 22 C A 92 8 3 1018 21 B B 91 8 4 1089 21 A C 91 8 5 1056 20 C 6 1042 18 B 7 1053 17 A 8 1007 15 C 9 1010 13 B 10 1028 13 A 11 1061 13 C 12 1005 12 B 13 1029 11 A 14 1082 10 A 15 1027 9 B 16 1022 8 C 17 1050 8 A 18 1093 8 B 19 1030 7 C 20 1080 7 A 21 1009 6 B 22 1065 5 C 23 1079 5 A 24 1049 4 B 25 1071 1 C の様に修正。 あとは、オートフィルタで、A、B、C の各組のデータを抽出し列ごとに並べます。 |
投稿日時: 24/08/23 10:27:51
投稿者: Suzu
|
|
---|---|
引用: アドレス間違えました。 正しくは E1 : =SUM(B2:B25) F1 : =E1/3 ---- 組分けの目標値 F2:=SUMIF(C$2:C$25,"="&$E2,B$2:B$25) 下オートフィル G2:=COUNTIF(C$2:C$25,"="&$E2) 下オートフィル です。 4組に分けるなら、同様にし、 C2〜C5、C6〜C9、・・と DCBA と 順に入れ替えて行けば良いかと。 A B C D E F G H 1 ID POINT 組 274 68.5 2 1069 22 D A 67 6 3 1018 21 C B 69 6 4 1089 21 B C 70 6 5 1056 20 A D 68 6 6 1042 18 D 7 1053 17 C 8 1007 15 B 9 1010 13 A 10 1028 13 D 11 1061 13 C 12 1005 12 B 13 1029 11 A 14 1082 10 A 15 1027 9 B 16 1022 8 C 17 1050 8 D 18 1093 8 A 19 1030 7 B 20 1080 7 C 21 1009 6 D 22 1065 5 A 23 1079 5 B 24 1049 4 C 25 1071 1 D |
投稿日時: 24/08/23 11:06:12
投稿者: tako552101
|
|
---|---|
すみません、説明が下手でしたでしょうか。
■3人組の場合 組 Aグループ Bグループ Cグループ ID POINT ID POINT ID POINT 合計値 1 1049 4 1027 9 1069 22 35 ← 合計値が各行共平均値 2 1079 5 1093 8 1018 21 34 ← となるようにしたい 3 1080 7 1005 12 1007 15 34 ← 4 1030 7 1082 10 1053 17 34 ← 5 1022 8 1028 13 1061 13 34 ← 6 1009 6 1050 8 1089 21 35 ← 7 1065 5 1029 11 1042 18 34 ← 8 1071 -1 1010 13 1056 22 34 ← ※上記は各行とも34、35でその差異1で平均が取れています。 よろしくお願いします。 |
投稿日時: 24/08/23 12:44:43
投稿者: Suzu
|
|
---|---|
縦でも横でも一緒では?
A B C D E F G H 1 ID POINT 組 274 34.25 2 1069 22 8 1 21 13.25 2 3 1056 22 7 2 22 12.25 2 4 1018 21 6 3 24 10.25 2 5 1089 21 5 4 24 10.25 2 6 1042 18 4 5 26 8.25 2 7 1053 17 3 6 26 8.25 2 8 1007 15 2 7 26 8.25 2 9 1028 13 1 8 21 13.25 2 10 1010 13 11 1061 13 12 1005 12 13 1029 11 14 1082 10 15 1027 9 16 1022 8 17 1093 8 18 1050 8 1 19 1080 7 2 20 1030 7 3 21 1009 6 4 22 1079 5 5 23 1065 5 6 24 1049 4 7 25 1071 -1 8 (ここまでだったら、VBAを使用しても良いのでは?) あとは、G列の不足POINTを目安に、手動でC10〜C17 に 1〜8 を割り振る。 引用: 今回は、差異「1」でしたが、そうで無い場合もありますよね? 様は、その「1」という しきい値 は変動しうるので 手動の方が調整しやすい のではありませんか? その手動調整について、どれだけ手間を省けるか。 入力だけ の方が 絶対に楽です。 セルの入れ替えなんかをやろうとするから、手間がかかるのです。 そんな整形は後で良いのです。 どんな組み合わせにするか を 手動でどれだけ楽にできるか を考えましょう。 |
投稿日時: 24/08/23 14:55:48
投稿者: sk
|
|
---|---|
引用: 「全ての参加者の人数」を「基本グループの数( 1 組当たりの基本人数)」で 除した際に 1 以上の剰余人数が発生した場合はどのように扱うのでしょうか。 例えば、全ての参加者の人数が 100、基本グループの数が 3 である場合の 除算の商は 100 \ 3 = 33、剰余は 100 Mod 3 = 1 となりますが、 「余った 1 名のみで 34 つめの組を作る」のと「 33 組のうちのいずれかの組に 追加枠を 1 名分ずつ振り分ける( 4 名枠の組が 1 つ、3 名枠の組が 32 つとなり、 1 名のみの D グループが生じる)」とでは大きく意味が異なります。 引用: また、そのイベントにおいて各参加者を「組」や「グループ」に 振り分ける目的を明記されることをお奨めします。 |
投稿日時: 24/08/23 15:46:47
投稿者: tako552101
|
|
---|---|
Suzuさん、ありがとうございます。
引用: 組み分けた例えば32(96名)グループは、グループ毎の持ちポイントをできるだけ平均化して、次のイベントで公平にグループ合計ポイントで競えるようにするためです。 |
投稿日時: 24/08/23 17:39:20
投稿者: sk
|
|
---|---|
引用: ではとりあえずの叩き台として、次のようなワークシートを元に 組分け処理を行なう場合。 ------------------------------------------------------------------- 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------------------------------------------------------------------- ( 標準モジュール) ------------------------------------------------------------------- Sub GroupingByPoint() '参照範囲の取得 Dim wsSource As Excel.Worksheet Dim rngSource As Excel.Range Dim lngFirstRow As Long Dim lngLastRow As Long 'このブックの 1 つめのワークシートを参照元とする Set wsSource = ThisWorkbook.Worksheets(1) With wsSource lngFirstRow = 2 lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row If lngLastRow < lngFirstRow Then Set wsSource = Nothing Exit Sub End If Set rngSource = .Range(.Cells(lngFirstRow, 1), _ .Cells(lngLastRow, 2)) End With 'メンバー情報の定義と初期化 Dim rsMembers As ADODB.Recordset Set rsMembers = New ADODB.Recordset With rsMembers .CursorLocation = adUseClient .CursorType = adOpenDynamic .LockType = adLockOptimistic .Fields.Append "ID", adInteger .Fields.Append "POINT", adInteger .Fields.Append "組", adInteger .Open End With Dim rngTargetRow As Excel.Range Dim varMembersCount As Variant Dim varTotalPoints As Variant varMembersCount = CDec(0) varTotalPoints = CDec(0) For Each rngTargetRow In rngSource.Rows '[ID]が記録されている行のみメンバ―情報に追加する If rngTargetRow.Columns(1).Value <> "" Then rsMembers.AddNew rsMembers![組].Value = 0 rsMembers![ID].Value = rngTargetRow.Columns(1).Value rsMembers![Point].Value = rngTargetRow.Columns(2).Value rsMembers.Update 'メンバー人数のカウント varMembersCount = varMembersCount + 1 'ポイント合計の加算 varTotalPoints = varTotalPoints + CLng(rngTargetRow.Columns(2).Value) End If Next '組分け対象となるメンバーが存在しない場合は終了 If varMembersCount = 0 Then rsMembers.Close Set rsMembers = Nothing Set rngSource = Nothing Set wsSource = Nothing Exit Sub End If Dim varAveragePoints As Variant '全メンバーのポイントの平均を取得 varAveragePoints = CDec(varTotalPoints / varMembersCount) '組情報の定義と初期化 Dim rsTeams As ADODB.Recordset Set rsTeams = New ADODB.Recordset With rsTeams .CursorLocation = adUseClient .CursorType = adOpenDynamic .LockType = adLockOptimistic .Fields.Append "組", adInteger .Fields.Append "人数", adInteger .Fields.Append "人数上限", adInteger .Fields.Append "POINT合計", adInteger .Fields.Append "POINT平均", adDouble .Open End With Const BasicMembersCountInTeam As Long = 3 Dim lngTeamsCount As Long Dim lngSurplusCount As Long Dim lngGroupsCount As Long lngTeamsCount = varMembersCount \ BasicMembersCountInTeam lngSurplusCount = varMembersCount Mod BasicMembersCountInTeam lngGroupsCount = BasicMembersCountInTeam - (lngSurplusCount <> 0) Dim lngTeam As Long For lngTeam = lngTeamsCount To 1 Step -1 rsTeams.AddNew rsTeams![組].Value = lngTeam rsTeams![人数].Value = 0 If lngSurplusCount > 0 Then rsTeams![人数上限].Value = BasicMembersCountInTeam + 1 lngSurplusCount = lngSurplusCount - 1 Else rsTeams![人数上限].Value = BasicMembersCountInTeam End If rsTeams.Update Next '組分け処理 Dim rsSubMembers As ADODB.Recordset Set rsSubMembers = rsMembers.Clone Dim lngTeamMembersCount As Long Dim varTotalPointsInTeam As Variant Dim varAveragePointsInTeam As Variant Dim varTheoreticalPoints As Variant '組情報を人数上限の昇順、組番号の昇順に並べ替える rsTeams.Sort = "[人数上限] ASC, [組] ASC" '全ての組情報を参照し終えるまでループ Do Until rsTeams.EOF '組のポイント合計の初期化 varTotalPointsInTeam = 0 Do '最初のメンバー選択時 If rsTeams![人数].Value = 0 Then 'まだ組が決まっていないメンバーを抽出し、 'ポイントの降順、IDの昇順に並べ替えた結果を得る rsMembers.Filter = "[組] = 0" rsMembers.Sort = "[POINT] DESC, [ID] ASC" '残り 1 枠になった場合 ElseIf rsTeams![人数].Value = (rsTeams![人数上限].Value - 1) Then '「全メンバーのポイント平均にこの組の人数上限を乗じた結果」から '「現時点での組のポイント合計」を減じた結果を求め、 '適正ポイントの理論値とする varTheoreticalPoints = (varAveragePoints * rsTeams![人数上限].Value) - varTotalPointsInTeam 'まだ組が決まっておらず、かつポイントが理論値以下であるメンバーを抽出し、 'ポイントの降順、IDの昇順に並べ替えた結果を得る。 'この時点で先頭となったメンバーが既定の候補者となる。 rsMembers.Filter = "([組] = 0) AND ([POINT]<=" & varTheoreticalPoints & ")" rsMembers.Sort = "[POINT] DESC, [ID] ASC" 'まだ組が決まっておらず、かつポイントが理論値より大きいメンバーを抽出し、 'ポイントの昇順、IDの昇順に並べ替えた結果を得る rsSubMembers.Filter = "([組] = 0) AND ([POINT]>" & varTheoreticalPoints & ")" rsSubMembers.Sort = "[POINT] ASC, [ID] ASC" 'どちらの結果にも候補者がいる場合 If (rsMembers.EOF = False) And (rsSubMembers.EOF = False) Then '候補者のポイントと適正ポイントの理論値との差がより小さい方の結果を採用する If Abs(rsMembers![Point].Value - varTheoreticalPoints) > Abs(rsSubMembers![Point].Value - varTheoreticalPoints) Then rsMembers.Filter = "[ID]=" & rsSubMembers![ID].Value rsMembers.Sort = "" End If '前者の結果に候補者がおらず、かつ後者の結果に候補者がいる場合 ElseIf (rsMembers.EOF = True) And (rsSubMembers.EOF = False) Then '後者の結果から候補者を選ぶ rsMembers.Filter = "[ID]=" & rsSubMembers![ID].Value rsMembers.Sort = "" 'どちらの結果にも候補者がいない場合 ElseIf (rsMembers.EOF = False) And (rsSubMembers.EOF = False) Then 'まだ組が決まっていないメンバーを抽出し、 'ポイントの昇順、IDの昇順に並べ替えた結果を得る rsMembers.Filter = "[組] = 0" rsMembers.Sort = "[POINT] ASC, [ID] ASC" End If '2 人目以降かつ残り 2 枠以上空いている場合 Else 'まだ組が決まっていないメンバーを抽出し、 'ポイントの昇順、IDの昇順に並べ替えた結果を得る rsMembers.Filter = "[組] = 0" rsMembers.Sort = "[POINT] ASC, [ID] ASC" End If '抽出結果の先頭のメンバーの組の割り当て rsMembers![組].Value = rsTeams![組].Value '現時点での組のポイント合計を加算 varTotalPointsInTeam = varTotalPointsInTeam + rsMembers![Point].Value rsMembers.Update '組の人数を 1 追加 rsTeams![人数].Value = rsTeams![人数].Value + 1 rsTeams.Update '組の人数が上限に達するまで繰り返す Loop Until rsTeams![人数].Value = rsTeams![人数上限].Value 'ポイントの合計と平均を保存 rsTeams![POINT合計].Value = varTotalPointsInTeam rsTeams![POINT平均].Value = varTotalPointsInTeam / rsTeams![人数].Value rsTeams.Update '次の組へ移動 rsTeams.MoveNext Loop '組分け結果の出力 rsTeams.Filter = "" rsTeams.Sort = "[組] ASC" rsMembers.Filter = "" rsMembers.Sort = "[組] ASC, [POINT] ASC, [ID] ASC" Dim wsDestination As Excel.Worksheet Dim lngTargetColumn As Long Dim lngColumn As Long '新規ブックの 1 つめのワークシートを出力先とする Set wsDestination = Workbooks.Add.Worksheets(1) With wsDestination lngTargetColumn = 1 For lngColumn = 0 To rsTeams.Fields.Count - 1 .Cells(1, lngTargetColumn + lngColumn).Value = rsTeams.Fields(lngColumn).Name Next .Cells(2, lngTargetColumn).CopyFromRecordset rsTeams lngTargetColumn = lngTargetColumn + rsTeams.Fields.Count + 1 For lngColumn = 0 To rsMembers.Fields.Count - 1 .Cells(1, lngTargetColumn + lngColumn).Value = rsMembers.Fields(lngColumn).Name Next .Cells(2, lngTargetColumn).CopyFromRecordset rsMembers .UsedRange.EntireColumn.AutoFit .Select .Cells(1, 1).Select End With rsSubMembers.Close Set rsSubMembers = Nothing rsMembers.Close Set rsMembers = Nothing rsTeams.Close Set rsTeams = Nothing Set rngSource = Nothing Set wsSource = Nothing Set wsDestination = Nothing End Sub ------------------------------------------------------------------- A、B、C のグループ分けに関しては詳細な仕様(どのような基準で グループを決めているのか、既に決定済みのグループを変更することが あるのか/変更してよいのか等)が不明であるため考慮していません。 引用: 「グループごとのポイントの合計/平均をなるべく均一化すること」 「組ごとのポイントの合計/平均をなるべく均一化すること」は あくまで別の問題でしょう。 |
投稿日時: 24/08/24 06:04:46
投稿者: tako552101
|
|
---|---|
skさん、ありがとうございます。
|
投稿日時: 24/08/28 12:01:47
投稿者: sk
|
|
---|---|
引用: 基本的にやってること自体は非常に大雑把で、 1. その時点で最もポイントが高い参加者を 1 名選ぶ。 2. その時点で最もポイントが低い参加者を 1 名選ぶ。 3. 上記 1, 2 で選ばれた参加者 2 名と同じ組にすると 最もバランスが良くなりそうな参加者を 1 名選ぶ。 4. 上記 1 〜 3 で選ばれた参加者 3 名を同じ組にする。 5. 上記 4 の 3 名を選択対象から除外し、残りの参加者を対象として 全ての組のメンバーが決まるまで上記 1 〜 4 を繰り返す。 という処理を行なっているに過ぎません。 引用: 以上のような仕組み上、後半の組に近づくほど 上記 1 〜 3 において選択対象となる参加者が 減っていくため偏りが生じやすくなります。 必ずしも理想通りの結果を得られるわけではありません。 何故にそのようなやり方を例示したのかと言えば、 上位 1 位の参加者には下位 1 位の参加者を、 上位 2 位の参加者には下位 2 位の参加者を…… といった具合にした方が「 3 人目のメンバー」を選ぶ際の ポイント合計の帳尻合わせがしやすく、またそれらの参加者を 同じ組にした根拠として簡潔で理解しやすいからです。 それもあくまで 1 組当たりの人数が 3 人だから通用する話であって、 人数が 4 人以上となった場合はまた「最もバランスが良くなりそうな参加者」を 選ぶ上での根拠や基準を別途考える必要があるでしょう。 また、そのイベントがどういった類のものかは分かりませんが、 「各組の各々が持っているポイントの合計が平均になるように」する という形が本当に適切であるかどうかについても検討の余地があります。 (私自身は「ポイントの合計」ではなく「ポイントの順位」を 組分けの根拠にした方がよいのではないかと考えます) 少なくとも「全ての組において、それぞれの組のポイントの合計が 一定の範囲まで近似、収束するまで演算を繰り返す」という手法だと、 扱うデータによっては永遠に演算が終わらなくなる可能性がありますし、 また理想に近い結果を得られたとしても「具体的にどのようなプロセスを経て そのような結果が導き出されたか」を誰にも説明することができない (説明できても理解されにくい)事態に陥ってもおかしくはありません。 引用: 引用: 上記の定数の値を変更すれば一応は可能ですが、それだけでは 組分け処理の精度が明らかに落ちることになるでしょう。 BasicMembersCountInTeam の値を 4 にした場合、 現在のフローでは上記 2 の処理を 2 回行なってから 上記 3 の処理を行なうことになります。 したがってポイント最上位の参加者は必ずポイント下位 2 名の 参加者達と同じ組にされます。 |
投稿日時: 24/08/29 15:07:45
投稿者: tako552101
|
|
---|---|
skさん、ありがとうございます。
|