【会員アンケートご協力のお願い】抽選で計5名様に役立つ書籍をプレゼント!

Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10全般 : 指定なし)
各メンバーの点数の合計をできるだけ均等にするようなグループ分けの方法について
投稿日時: 24/08/28 09:52:45
投稿者: simple

 「各人の持っているポイントをもとに、
  各メンバーのポイント合計ができるだけ均等になるようなグループ分けの方法」に関する
議論がありました。
https://www.moug.net/faq/viewtopic.php?t=82852
 
質問者さんは解決済みとされているようで、回答があっても何の反応もなく放棄されているようです。
気持ちを入れ替えて、閲覧者に向けてメモを書いておくことにしました。
 
まずは元データと試算結果だけを書き、コードは次の発言に記載します。
 
(■例1) 24人を1グループ3人の8グループに分けるケース
<Sheet1> 元データ

        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コードを書きます。
 
<データシートの準備>
・データシートは一番左に置いて下さい。
・データは、一行目に見出しを書きます。
・C列は空白列にしてください。
・D:E列を作業領域に使います。そこは空けておいてください。
・IDは文字列でも数値でもOKです。
 
<マクロ関係>
・データシートのあるブックの標準モジュールに以下のコードを転記します。
・「一組のメンバーの人数」(変数 numOfgroupMembers)を適切に設定してください。(■要修正部分です)
・main プロシージャを実行して下さい。
・別のブックが作成され、シートに結果が表示されます。
・100人だとたぶん1秒以内です。
 
■以下、参考コードです。

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さんから当方の発言へのコメントをいただきました。ありがとうございます。
本来なら元スレッドに投稿すべきかもしれませんが、質問者さんに関係しないことなので、
こちらでコメント致します。
 
| 少なくとも「全ての組において、それぞれの組のポイントの合計が
| 一定の範囲まで近似、収束するまで演算を繰り返す」という手法だと、
| 扱うデータによっては永遠に演算が終わらなくなる可能性がありますし、
| また理想に近い結果を得られたとしても「具体的にどのようなプロセスを経て
| そのような結果が導き出されたか」を誰にも説明することができない
| (説明できても理解されにくい)事態に陥ってもおかしくはありません。

 
他者への説明は、「各組の合計点ができるだけ均等になるように設定しました」ということです。
そもそも最初の質問はそういうものでした。その前提に従って作成したというだけです。
「多数回の試算をして案を作成しました。もしもっと均等になるものがあれば、
  あなたがその案を提示して下さい」で十分ではないですか?
 
| 扱うデータによっては永遠に演算が終わらなくなる可能性があります
そうしたことは起きません。(というか、そのために繰り返し回数上限を指定しています)
・iter変数をループ変数とする一回の処理では、ループは必ず有限回で終わります。
 (単純な多重ループなので。)
・二つの組のメンバーどうしを交換することによって、二つの組の合計の差が縮小することを
 要件にしていますから、実際に交換するたびに、各組の和の母標準偏差は単調に減少します。
 (つまり均等なものに近づくということです)
・また、その処理の繰り返し回数(maxIterations変数)を指定することで必要な回数だけ
 実行するようにしています。
 3,4回程度で定常状態になる(つまり交換はそれ以上発生しない)ようですから、
 効率を考えて maxIterations を 5 に設定しています。
 (ケースによっては増やす必要があるかもしれません)
 
【留意点】
なお、定常状態に陥ったときに、それが最適である理論上の保証は無いことに注意が必要です。
(初期設定では昇順ソートした結果をセットしていますが、少なくとも初期組み合わせに依存する
可能性があります。)
ただし、実際のシミュレーションの結果を見る限り、それなりの結果は得られているように思います。

回答
投稿日時: 24/08/29 11:14:25
投稿者: sk

引用:
skさんから当方の発言へのコメントをいただきました。

件のスレッドでの回答は simple さんに宛てたものではありません。

投稿日時: 24/08/29 11:27:09
投稿者: simple

そうでしたか、了解しました。

トピックに返信