[[20091108213418]]　『ランダムな数字をなるべく均等に並べ替えるには』（54-71）　ページの最後に飛ぶ

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

　

『ランダムな数字をなるべく均等に並べ替えるには』（54-71）

異なる数字がいくつかあります。

それをいくつかの組に振り分けます。

その時、各組の合計ができるだけ均等になるように並べ替えたいのです。

わかりやすく一例を挙げると、
次のような数字が14個あるとします。

　236/178/195/213/147/108/118

　221/160/124/200/139/155/182

これを4組になるべく均等に並べるとすると

　A．236/139/118/108

　B．221/195/178

　C．213/200/182

　D．160/155/147/124

例えばこんな感じになります。

もちろんこれ以外にもっと均等な組み合わせが何通りもあると思いますが、この並べ替えを簡単にできる方法を教えて頂きたいのです。

補足になりますが、はじめの異なる数字というのは、概ね100〜500の間の整数です。

それが8〜18個あります。それを2〜6組に振り分けます。

つまり、8個のランダムな数字を2つの組に振り分けることもあれば、18個のランダムな数字を6つの組に振り分けることもあるということです。

何が目的かと思われるかもしれませんが、仕事で必要な作業です。

ズバリな方法があれば嬉しいのですが、それ以外でも何かヒントになるようなことでいいのでご教授ください。よろしくお願いします。

バージョンは、Excel2003、WindowsXPです。

---

 誰かしらのコメントが付かないかなぁとしばらく様子見てましたが、やっぱ付かないなぁ。
私もちょっと頭ひねっては見ましたが、簡単な方法は……うーん、と。
　
で、一般的にこの手の解法ってどうすんのよと探してみましたが、
求めたい事って、多分この問題に当たるんじゃないかな？と。
　
組合せ最適化
http://ja.wikipedia.org/wiki/%E7%B5%84%E5%90%88%E3%81%9B%E6%9C%80%E9%81%A9%E5%8C%96
　
要は非常に難しい問題なんじゃないかなと。
（ご近所PG）

---

 だいぶ前に、こんな問題に投稿したことがありました（ちょっと前にも同じコメントを記述した覚えがあるなあ）。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=19957;id=excel

 質問内容は、このスレッドの先頭を見てください。
 尚、リンク先のコードには未定義変数がたくさん使われています（反省）。
 よって、各モジュールの先頭行には、

 Option Explicit

 を付けないようにしてください。
 自動的に挿入されるような設定になっている場合、面倒でも削除してください。

 本来は、Option Explicit
 は付けた方が良いので、解読する気があるなら、御自分で変数宣言しても結構です。

 ここで作成したプロシジャーを引用すると・・・、

 例題の数字を扱うと、

 新規ブックの標準モジュールに

 '==================================================================================
 Option Explicit
 '========================================================
 Sub test()　'ここだけは、ちょっと変更しました
   Dim wkarray As Variant
   Dim in_array As Variant
   Dim wk As Long
   Dim g0 As Long
   Dim g1 As Long
   Dim g2 As Long
   Dim ans As Long
   Dim ele As Variant
   Dim asum() As Long
   Dim 組合せ
   Dim 組み分け数 As Long
   Dim pat() As Long
   ReDim pat(1, 1)
   pat(0, 0) = 4: pat(0, 1) = 2
   pat(1, 0) = 3: pat(1, 1) = 2
   組み分け数 = 4
   ReDim asum(組み分け数 - 1)
   Range("a1:n1").Value = Array(236, 221, 213, 200, 195, 182, 178, 160, 155, 147, 139, 124, 118, 108)
   MsgBox "セルA1:N1の数字をばらつきが極力ないように　４，４，３，３個にグループに分けます"
   in_array = Application.Transpose(Application.Transpose(Range("a1:n1").Value))
   組合せ = dist_array(in_array, "*", 組み分け数, pat)
   Debug.Print UBound(組合せ, 1)
   ans = 10000
   g2 = 0
   For g0 = LBound(組合せ, 1) To UBound(組合せ, 1)
       With Application

         For g1 = LBound(組合せ, 2) To UBound(組合せ, 2)
            asum(g1) = 0
            For Each ele In Split(組合せ(g0, g1), "*")
               asum(g1) = asum(g1) + Val(ele)
            Next
         Next
         wk = .Max(asum()) - .Min(asum())
          If wk < ans Then
             g2 = g0
             ans = wk
          End If
       End With
   Next
   For g0 = LBound(組合せ, 2) To UBound(組合せ, 2)
      wkarray = Split(組合せ(g2, g0), "*")
      With Range("a" & g0 + 2).Resize(, UBound(wkarray) + 1)
         .Value = wkarray
         .Value = Application.Evaluate("if(" & .Address & "<>"""",value(" & .Address & "))")
      End With
   Next
 End Sub

 別の標準モジュールに

 '=====================================================================================
 Option Explicit
 Function dist_array(ByVal in_array As Variant, ByVal delimter As String, ByVal 組み分け数 As Long, ByVal patturn, _
                    Optional ByVal pdx As Long = 0, Optional ByVal nest As Long = 0, Optional ByVal dupmd As Long = 0)
 '指定された配列を指定された組み分け数でグループ化する
 'グループ化の詳細は、配列Patturnの値による
 'input　:　in_array ----組み分け数配列（１次元配列)
 '          delimiter---同一グループ内を区切る文字
 '          組み分け数---グループ化する数
 '          patturnグループメンバ数等の情報（２次元配列）
 '
 '          例1　Array("a", "b", "c", "d", "e", "f", "g", "h")を
 '          1,3,4の３グループに分ける場合、
 '          dim pat(2,1)
 '          メンバ数　　メンバ数の重複回数
 '          pat(0,0)=1　　pat(0,1)=1
 '          pat(1,0)=3    pat(1,1)=1
 '          pat(2,0)=4　  pat(2,1)=1
 '　　　　　 組み分け数 = 3
 '　　　　   組合せ = _
　　　　　　　dist_array(Array("a", "b", "c", "d", "e", "f", "g", "h"),"**", 組み分け数, pat())
 '
 '
 '          例2　Array("a", "b", "c", "d", "e", "f", "g", "h")を
 '          3,3,2の３グループに分ける場合、
 '          dim pat(1,1)
 '          メンバ数　　メンバ数の重複回数
 '          pat(0,0)=3　　pat(0,1)=2
 '          pat(1,0)=2    pat(1,1)=1
 '　　　　　 組み分け数 = 3
 '　　　　   組合せ = _
　　　　　　　dist_array(Array("a", "b", "c", "d", "e", "f", "g", "h"),"**", 組み分け数, pat())
 '
 '          例3　Array("a", "b", "c", "d", "e", "f", "g", "h")を
 '          2,2,2,2の4グループに分ける場合、
 '          dim pat(0,1)
 '          メンバ数　　メンバ数の重複回数
 '          pat(0,0)=2　　pat(0,1)=4
 '　　　　　 組み分け数 = 4
 '　　　　   組合せ = _
 　　　　　　dist_array(Array("a", "b", "c", "d", "e", "f", "g", "h"), "**",組み分け数, pat())
 '
 '
 'output :  dist_array ２次元配列　1次元目がメンバ数
 '                                2次元目がグループ化されたメンバの組合せ
 'pdx nest dupmdは、指定不可　内部処理データ
   Static dup() As Class1
   Static ans()
   Static adx As Long
   Static c_array()
   Dim ll, jj
   Dim menum As Long
   Dim d_cnt As Long
   Dim myarray1 As Variant
   Dim myarray2 As Variant
   Dim idx As Long, jdx As Long, dpx As Long
   Dim kdx As Long
   Dim retcode As Long
   If nest = 0 Then
      menum = 1
      d_cnt = UBound(in_array) - LBound(in_array) + 1
      With WorksheetFunction
        For ll = LBound(patturn) To UBound(patturn)
           For jj = 1 To patturn(ll, 1)
              menum = menum * .Combin(d_cnt, patturn(ll, 0))
              d_cnt = d_cnt - patturn(ll, 0)
              Next jj
           menum = menum / .Fact(patturn(ll, 1))
           Next ll
        End With
      ReDim ans(menum - 1, 組み分け数 - 1)
      ReDim c_array(組み分け数 - 1)
      ReDim dup(UBound(in_array))
      adx = 0
      pdx = 0
      If patturn(pdx, 1) > 1 Then
         dupmd = 1
      Else
         dupmd = 0
         End If
      End If
   If patturn(pdx, 1) = 0 Then
      If pdx + 1 <= UBound(patturn, 1) Then
         pdx = pdx + 1
         If patturn(pdx, 1) > 1 Then
            dupmd = 1
         Else
            dupmd = 0
            End If
      Else
         Exit Function
         End If
      End If
   If dupmd >= 1 Then
      Set dup(nest) = New Class1
      dup(nest).duparray_init UBound(in_array)
      End If
   patturn(pdx, 1) = patturn(pdx, 1) - 1
   myarray1 = combin_list(in_array, patturn(pdx, 0))
   For idx = LBound(myarray1, 1) To UBound(myarray1, 1)
      ReDim tmp(UBound(myarray1, 2))
      For jdx = LBound(myarray1, 2) To UBound(myarray1, 2)
        tmp(jdx) = myarray1(idx, jdx)
        Next jdx
      retcode = 0
      If dupmd > 1 Then
         For dpx = nest - dupmd + 1 To nest - 1
            retcode = dup(dpx).duparray_chk(tmp())
            If retcode <> 0 Then Exit For
            Next dpx
         End If
      If retcode = 0 Then
         If dupmd >= 1 Then
            dup(nest).duparray_put myarray1(idx, 0)
            End If
         c_array(nest) = Join(tmp(), delimter)
         If nest = 組み分け数 - 1 Then
            For kdx = LBound(c_array()) To UBound(c_array())
               ans(adx, kdx) = c_array(kdx)
               Next kdx
            adx = adx + 1
            End If
         myarray2 = except_array(in_array, tmp())
         Erase tmp()
         Call dist_array(myarray2, delimter, 組み分け数, patturn, pdx, nest + 1, dupmd + 1)
         End If

      Next idx
    If nest = 0 Then
       dist_array = ans()
       Erase ans()
       Erase c_array()
       On Error Resume Next
       For idx = UBound(dup()) To LBound(dup())
          If Not dup(idx) Is Nothing Then
             dup(idx).duparray_term
             End If
          Set dup(idx) = Nothing
          Next
       Erase dup()
       On Error GoTo 0
       End If
 End Function
 Function except_array(in_array, exarray()) As Variant
 '指定された配列から、指定された配列メンバを除いた配列を返す
 'input : in_array 対象の配列（１次元配列）
 '        exarray() 取り除くメンバを含んだ配列（１次元配列）
 'output: except_array -取り除かれた配列
   Dim n_array()
   Dim jdx As Long
   Dim idx As Long
   Dim ok As Boolean
   Dim ex As Long
   For idx = LBound(in_array) To UBound(in_array)
      ok = True
      For ex = LBound(exarray()) To UBound(exarray())
        If in_array(idx) = exarray(ex) Then
           ok = False
           Exit For
           End If
        Next ex
      If ok = True Then
         ReDim Preserve n_array(jdx)
         n_array(jdx) = in_array(idx)
         jdx = jdx + 1
         End If
      Next
   except_array = n_array()
 End Function
 '========================================
 Function combin_list(総リスト, 抜取り数, Optional ByVal nest As Long = 0, Optional ByVal st As Long = 0)
 '組合せリストを作成する
 'input :総リスト----組合せリストを作成する元リスト（１次元の配列）
 '　　　 抜取り数----組合せ抜取り数
 ' nest及び、stは、指定不可　内部で使用するパラメータ
 'output:combin_list---組合せリスト２次元配列
   Static ans()
   Static idx() As Long
   Static jdx As Long
   Dim kdx As Long
   If nest = 0 Then
      jdx = 0
      ReDim idx(抜取り数 - 1)
      ReDim ans(WorksheetFunction.Combin(UBound(総リスト) - LBound(総リスト) + 1, 抜取り数) - 1, 抜取り数 - 1)
      st = LBound(総リスト)
      End If
   For idx(nest) = st To UBound(総リスト)
      If nest < 抜取り数 - 1 Then
         Call combin_list(総リスト, 抜取り数, nest + 1, idx(nest) + 1)
      Else
         For kdx = 0 To 抜取り数 - 1
           ans(jdx, kdx) = 総リスト(idx(kdx))
           Next kdx
         jdx = jdx + 1
         End If
      Next
   If nest = 0 Then
      combin_list = ans()
      End If
 End Function

 最後にクラスモジュール（クラス名は、Class1）に
 '=================================================================
 Option Explicit
 Private duparray()  '重複チェック用配列
 Private fdx As Long '配列のポインタ
 Sub duparray_init(array_num As Long) '重複チェックを初期化
   Dim idx As Long
   ReDim duparray(array_num)
   For idx = LBound(duparray()) To UBound(duparray())
      duparray(idx) = ""
      Next idx
   fdx = 0
 End Sub
 '=================================================================
 Sub duparray_term()
   '重複チェックの終わり
   On Error Resume Next
   Erase duparray()
 End Sub
 '=================================================================
 Sub duparray_put(myvalue)
   'チェックメンバの追加
   Dim menflg As Boolean
   Dim idx As Long
   menflg = True
   For idx = LBound(duparray()) To fdx - 1
      If duparray(idx) = myvalue Then
         menflg = False
         Exit For
         End If
      Next idx
   If menflg = True Then
      duparray(fdx) = myvalue
      fdx = fdx + 1
      End If
 End Sub
 '=================================================================
 Function duparray_chk(myvalue()) As Long
   '重複のチェック
   'out duparray_chk 0--重複なし　1--重複あり
   Dim idx As Long, jdx As Long
   duparray_chk = 0
   For idx = LBound(duparray()) To fdx - 1
      For jdx = LBound(myvalue) To UBound(myvalue)
         If duparray(idx) = myvalue(jdx) Then
            duparray_chk = 1
            Exit For
            End If
         Next jdx
      If duparray_chk = 1 Then Exit For
      Next idx
 End Function

 これでtestを実行してみてください。
 内容は、（54-71）さんが、提示された数字の4グループに均等分けします。

 但し、　内訳は、　グループメンバ数を４，４，３，３というように決め打ちでの実行です。

 この組合せを洗い出して、そのグループの合計を出し、その合計中の最大値ー最小値の値が一番少ない組合せを抽出します。
 上記のtestを実行すると、13〜14分の処理します（私の環境で）。
 実際には、４，４，３，３だけではないですよね？
 この４，４，３，３という組合せだけでも1051050ありました。
 もっと多い場合もあると、メモリオーバーになるかもしれないので工夫が必要かもしれません。

 結果は、Ａ２から、
 213	155	118	108   ←これが、一グループ
 182	147	139	124   ←これが、一グループ
 236	200	160            ←これが、一グループ
 221	195	178            ←これが、一グループ

 となります。54-71さんが例としてあげた組合せより、ちょっとだけ均等な結果です。

 試してみてください

 ichinose

---

 一つの解法と言う事で自分も考えてみました。
これは局所探索法？になるのかな？
　
・前提条件
値の割り振りは、例えば今回の場合で言うと、
14個の値を4つに分ける場合、4,4,3,3に分けます。
14個の値を3つに分ける場合、5,5,4に分けます。
14個の値を2つに分ける場合、7,7に分けます。
（3つに分ける場合に6,4,4と分けたり、2つに分ける場合に8,6と分けたりは考えてません）
　
・実行方法
新規ブックのSheet1の1行目から、以下のレイアウトでデータを配置します。
値リストに割り振りたい値を縦にずらっとA列に配置。
それをいくつのグループに分けたいかを分割数としてB2セルに。
C2セルの試行回数ってのは、組合せを適当に入れ換えるその回数です。
増やしても減らしても良いけど、あんま結果の精度は良くならなかったかな。
　
[A]	[B]	[C]	[D]
値リスト	分割数	試行回数	試行結果
236	4	100	
178			
195			
213			
147			
108			
118			
221			
160			
124			
200			
139			
155			
182			
　
標準モジュールに以下のコードをぺったり貼り付けます。
'↓↓↓ここから↓↓↓
Option Explicit
Sub testloop()
    Dim i As Integer
    For i = 1 To 1000
        Call test
    Next
    MsgBox "end"
End Sub
Sub test()
    Dim colValues As New Collection
    Dim colGroup As New Collection
    Dim i As Integer
    Dim idx As Integer
    Dim r As Range
    Dim valueCount As Integer
    Dim s As Worksheet
    Dim TargetValue As Double
    Dim diff As Double
    Dim prediff As Double
    Dim ret As String
    Dim divCount As Integer
    Dim loopCount As Long
    '対象シート
    Set s = Worksheets("Sheet1")
    '設定値取得
    divCount = s.Range("B2").Value
    loopCount = s.Range("C2").Value
    '対象となる値リスト取得
    For Each r In s.Range("A2:A" & s.Range("A" & s.Rows.Count).End(xlUp).Row)
        colValues.Add r.Value
    Next
    '値を保持する枠組み生成
    For i = 1 To divCount
        colGroup.Add New Collection
    Next
    '適当に割り振る
    valueCount = colValues.Count
    For i = 0 To valueCount - 1
        idx = i Mod colGroup.Count + 1
        colGroup(idx).Add pickup(colValues)
    Next
    '目標とする値
    TargetValue = GetTargetValue(colGroup)

    '初期化
    prediff = 9 ^ 9
    diff = 0
    '試行回数分繰り返し
    For i = 1 To loopCount
        '最も目標値から外れたグループを判別
        idx = GetChangeIndex(colGroup, TargetValue)
        'Debug.Print idx & vbTab & ToString(colGroup)
        '処理対象とするグループがあるなら
        If idx > 0 Then
            '値の入れ換えを行なう
            If Not ChangeValues(colGroup, TargetValue, idx, i) Then
                'ためし終わった？
                Exit For
            End If
        End If
        '目標との差の合計を取得する
        diff = GetDiff(colGroup, TargetValue)
        '今回の差が前回最適解よりも縮んでいたら最適解として保持
        If diff < prediff Then
            prediff = diff
            ret = "差の合計:" & Format(diff, "@@@@") & " " & "目標値:" & Format(TargetValue, "@@@@") & " 結果:" & ToString(colGroup)
        End If
        '全てが目標値になったなら終わる
        If diff = 0 Then
            Exit For
        End If
    Next
    '最終的に得られた解を提示
    'Debug.Print ret
    s.Range("D" & s.Range("D" & s.Rows.Count).End(xlUp).Row + 1).Value = ret
    'MsgBox "処理完了" & vbCrLf & ret
End Sub
'値リストからランダムに取り出す
Private Function pickup(ByRef values As Collection) As Double
    Static blnInit As Boolean
    Dim idx As Integer
    Dim ret As Double
    If Not blnInit Then
        Randomize
        blnInit = True
    End If
    idx = Int(Rnd * values.Count) + 1
    ret = values(idx)
    values.Remove idx
    pickup = ret
End Function
'目標値を得る
Private Function GetTargetValue(ByRef group As Collection) As Double
    Dim ret As Double
    Dim obj As Collection
    ret = 0
    For Each obj In group
        ret = ret + GetSum(obj)
    Next
    ret = ret / group.Count
    GetTargetValue = ret
End Function
'目標値との差の絶対値の合計を得る
Private Function GetDiff(ByRef group As Collection, ByVal target As Double) As Double
    Dim ret As Double
    Dim obj As Collection
    ret = 0
    For Each obj In group
        ret = ret + Abs(target - GetSum(obj))
    Next
    GetDiff = ret
End Function
'グループの値の合計を得る
Private Function GetSum(ByRef values As Collection) As Double
    Dim ret As Double
    Dim val As Variant
    ret = 0
    For Each val In values
        ret = ret + val
    Next
    GetSum = ret
End Function
'最も目標値から外れたグループのインデックスを得る
Private Function GetChangeIndex(ByRef group As Collection, ByVal target As Double) As Integer
    Dim ret As Integer
    Dim idx As Integer
    Dim diff As Double
    Dim prediff As Double
    Dim obj As Collection
    ret = 0
    prediff = 0
    For idx = 1 To group.Count
        Set obj = group(idx)
        diff = Abs(target - GetSum(obj))
        If diff > prediff Then
            ret = idx
            prediff = diff
        End If
    Next
    GetChangeIndex = ret
End Function
'1つだけ値を入れ換えて目標値に近づける
'Falseが返った場合は入れ換え不能(入れ換えパターンが尽きたとか)
Private Function ChangeValues(ByRef group As Collection, ByVal target As Double, ByVal baseIndex As Integer, ByVal tryCount As Integer) As Boolean
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim baseValueIndex As Integer
    Dim changeIndex As Integer
    Dim changeValueIndex As Integer
    Dim baseGroup As Collection
    Dim otherGroup As Collection
    Dim targetdiff As Double
    Dim diff As Double
    Dim prediff As Double
    Dim baseValue As Double
    Static dic As Object
    Static blnInit As Boolean
    Dim key As String
    '初期化
    ChangeValues = False
    baseValueIndex = 0
    prediff = 9 ^ 9
    If Not blnInit Then
        Set dic = CreateObject("Scripting.Dictionary")
        blnInit = True
    End If
    If tryCount = 1 Then
        dic.RemoveAll
    End If
    '目標値との差を取得
    targetdiff = target - GetSum(group(baseIndex))
    '自身のグループ内から、差を埋めるに最も適した値の組合せを検索
    Set baseGroup = group(baseIndex)
    For i = 1 To baseGroup.Count
        For j = 1 To group.Count
            '自身のグループは無視
            If j = baseIndex Then
                GoTo NEXT_INDEX
            End If
            Set otherGroup = group(j)
            For k = 1 To otherGroup.Count
                diff = targetdiff - (otherGroup(k) - baseGroup(i))
                '求める差に最も近いもののIndexを保持
                If Abs(diff) < Abs(prediff) Then
                    key = i & vbTab & j & vbTab & k & vbTab & otherGroup(k) & vbTab & baseGroup(i)
                    If dic.Exists(key) Then
                        '既に入れ換えたパターンは無視する？大丈夫？
                        dic.Item(key) = dic.Item(key) + 1
                        If dic.Item(key) = 7 Then
                            dic.Remove key
                        End If
                    Else
                        dic.Add key, 1
                        baseValueIndex = i
                        changeIndex = j
                        changeValueIndex = k
                        prediff = diff
                    End If
                End If
            Next
NEXT_INDEX:
        Next
    Next
    '入れ換え対象について入れ換える
    If baseValueIndex > 0 Then
        baseValue = group(baseIndex)(baseValueIndex)
        group(baseIndex).Remove baseValueIndex
        group(baseIndex).Add group(changeIndex)(changeValueIndex)
        group(changeIndex).Remove changeValueIndex
        group(changeIndex).Add baseValue
        ChangeValues = True
    End If
End Function
'結果文字列生成
Private Function ToString(ByRef group As Collection) As String
    Dim ret As String
    Dim strWk As String
    Dim obj As Collection
    Dim val As Variant
    Dim dblSum As Double
    ret = ""
    For Each obj In group
        strWk = ""
        dblSum = 0
        For Each val In obj
            dblSum = dblSum + val
            strWk = strWk & "," & val
        Next
        ret = ret & "/" & Mid(strWk, 2) & "(" & dblSum & ")"
    Next
    ToString = Mid(ret, 2)
End Function
'↑↑↑ここまで↑↑↑
　
マクロの実行で「test」を実行します。
すると実行する度に、試行結果がD列に追記されていきます。
追記されるのは以下のような文字列です。
1回の実行で1行ずつ追加されます。
　
差の合計:   4 目標値: 594 結果:139,124,118,213(594)/155,182,108,147(592)/221,195,178(594)/236,200,160(596)
差の合計: 110 目標値: 594 結果:108,160,221,147(636)/195,155,118,139(607)/182,236,124(542)/200,178,213(591)
差の合計:   6 目標値: 594 結果:155,124,195,118(592)/178,147,108,160(593)/236,221,139(596)/213,182,200(595)
差の合計: 222 目標値: 594 結果:182,178,124,213(697)/139,160,195,108(602)/118,147,236(501)/200,155,221(576)
差の合計: 298 目標値: 594 結果:182,200,160,124(666)/195,213,155,108(671)/147,178,236(561)/139,221,118(478)
差の合計: 138 目標値: 594 結果:160,108,118,139(525)/155,182,200,124(661)/178,221,195(594)/147,236,213(596)
差の合計:   6 目標値: 594 結果:124,195,155,118(592)/178,160,108,147(593)/221,236,139(596)/200,182,213(595)
差の合計:  42 目標値: 594 結果:147,200,108,160(615)/118,139,213,124(594)/155,182,236(573)/221,195,178(594)
差の合計:  90 目標値: 594 結果:178,155,182,124(639)/147,108,139,200(594)/195,236,118(549)/160,213,221(594)
差の合計: 138 目標値: 594 結果:155,108,182,195(640)/124,118,213,139(594)/178,200,147(525)/160,221,236(617)
　
差の合計って値が出来るだけ0に近いほうが、均等な結果と言えます。
目標値ってのは、与えられた値リストの合計値を分割数で割った値です。
プログラムは、各分割グループをこの値に近づけようとします。
それ以降、カンマで区切られた値が結果です。
スラッシュの区切りが1つのグループです。
括弧内の値は、そのグループ内の値の合計値です。参考までに出したものです。
　
見て分かるように、試行毎の結果のぶれが激しいです。
1発で満足の行く組合せが得られるとは思わず、何度か繰り返し実行してみて、
「これで良いかなぁ……」と思える組合せが出るまで試行してみてください。
　
 以下はちょっと個人的な仕様の覚え書きです。
・値の合計を分割グループ数で割り、目標値を取得。
・ランダムにグループ分けを行なう
　・１つの目標からかけ離れたグループに対し、その中のどれか一つの値を入れ換える候補を探す。
　　・目標値との差と、自グループ内と他グループ内の値を入れ換えた場合の差がもっとも近いものを選出し、入れ換える。
　　・全グループに対して処理を行った結果を保持し、再度入れ換えを行なう。
　・上記を任意回数繰り返し、最も差の絶対値の累積が小さい物を最適解として保持する。
・再度ランダムにグループ分けを行い、任意回数繰り返す。（今回はココを手動で行なう事にした）
・最終的にもっとも差の絶対値の累積が小さい物を最適解として提示する。
　
2009/11/11 20:53
一度試した入れ換えパターンを弾くロジックを追加しました。
結果、かなり精度が上がったみたい。
改良後、10回試行した結果は以下。
　
差の合計:   4 目標値: 594 結果:147,200,108,139(594)/124,195,155,118(592)/236,182,178(596)/213,221,160(594)
差の合計:   6 目標値: 594 結果:118,124,195,155(592)/147,108,160,178(593)/236,139,221(596)/200,213,182(595)
差の合計:   4 目標値: 594 結果:200,108,139,147(594)/118,124,195,155(592)/221,160,213(594)/182,236,178(596)
差の合計:   4 目標値: 594 結果:124,118,155,195(592)/139,108,147,200(594)/160,221,213(594)/236,182,178(596)
差の合計:   4 目標値: 594 結果:147,108,124,213(592)/155,182,118,139(594)/221,195,178(594)/200,236,160(596)
差の合計:   4 目標値: 594 結果:124,195,118,155(592)/147,139,108,200(594)/213,221,160(594)/236,182,178(596)
差の合計:   4 目標値: 594 結果:139,118,155,182(594)/108,124,200,160(592)/147,236,213(596)/221,195,178(594)
差の合計:   6 目標値: 594 結果:118,139,124,213(594)/108,147,160,182(597)/236,200,155(591)/195,221,178(594)
差の合計:   4 目標値: 594 結果:139,155,118,182(594)/200,108,160,124(592)/195,221,178(594)/236,213,147(596)
差の合計:   4 目標値: 594 結果:108,147,200,139(594)/124,155,118,195(592)/213,160,221(594)/182,236,178(596)
　
2009/11/11 21:02〜21:10
全てのグループがぴったり一致した場合にエラーが発生していたので修正。
　
2009/11/12 10:58
・testloop追加
・改廃動作追加
入換対象となった回数を保持して、一定回数以上入れ換えをしようとしたら、
一旦改廃するような動きを導入してみた。
以下、検証結果。
　
・試行回数100回を、1000回繰り返し実行
改廃導入前
　差が 4…… 962/1000回
　差が 6……  37/1000回
　差が26……   1/1000回
改廃導入後
　差が 4…… 983/1000回
　差が 6……  17/1000回
　
・試行回数1000回を、1000回繰り返し実行
改廃導入前
　差が 4…… 989/1000回
　差が 6……   8/1000回
　差が26……   2/1000回
改廃導入後
　差が 4……1000/1000回
　
・試行回数1000回を、10000回繰り返し実行
改廃導入後
　差が 4……10000/10000回
　
改廃の動作の導入する事、及び試行回数を上げる事、そのどちらでも精度が上がり、
これらを同時に適用する事で、今回の試行では100%の結果が得られた。
けどデータ量とかによって最適な設定って違いそうなので、あくまで一例。
（ご近所PG）

---

いろいろなご意見ありがとうございます！

本当に参考になりました。
昨日、今日と早速職場で使わせていただき、

今までの煩わしさから解放されました。
これで作業の効率も数段アップします。

引き続き、他の方法があれば是非教えてください。

(54-71)

---

 ご無沙汰しております。質問者です。
 ご近所PGさん伝授の方法で有効に活用させて頂いております。

 さて、一部改善したい部分が出てきたのですが、
 どこをどう変えればいいのか見当もつきませんので、
 図々しくも再度質問させていただきます。

 レアケースなのですが次のような例がありました。
 値リストは以下の13個の数値です。
 190/145/115/118/155/232/190/250/250/250/250/250/250

 これを分割数「5」で実行した場合のD列の試行結果は、

 差の合計: 116 目標値: 529 結果:115,250,190(555)/145,232,155(532)/250,118,190(558)/250,250(500)/250,250(500)
 差の合計: 116 目標値: 529 結果:115,190,232(537)/145,250,155(550)/250,118,190(558)/250,250(500)/250,250(500)
 差の合計: 116 目標値: 529 結果:145,250,155(550)/115,232,190(537)/250,118,190(558)/250,250(500)/250,250(500)
 差の合計: 116 目標値: 529 結果:115,250,190(555)/232,155,145(532)/250,118,190(558)/250,250(500)/250,250(500)
 差の合計: 116 目標値: 529 結果:155,145,232(532)/250,118,190(558)/190,250,115(555)/250,250(500)/250,250(500)

 概ねこんな感じになりました。
 この「差の合計」の部分を変更したいのです。

 差の合計ではなくて、()で表記されている分割後の合計値の、
 「最小値と最大値の差」が表示されるようにはできないでしょうか。

 つまり上記の例でいうと、差の合計はすべて「116」なのですが、
 最小値(500)と最大値(558)の差はすべて「58」になります。
 この「58」が試行結果に表示されるように変更したいのです。

 多くの場合、「差の合計値」が「最小値と最大値の差」と等しいか、
 あるいはそれにかなり近い結果になるのですが、
 たまに今回のようなケースがあります。
 勝手ながら直感的に知りたいのは後者の数値になるので、
 どうにか改善したいと考えております。

 すこし分かりにくい説明かもしれませんが、
 何かいい方法があれば教えて頂きたいのです。
 よろしくお願いします。

 （54-71）

---

 もう一年近く前だったんですね（遠い目
　
'↓↓↓ここから↓↓↓
Option Explicit
Sub testloop()
    Dim i As Integer
    For i = 1 To 1000
        Call test
    Next
    MsgBox "end"
End Sub
Sub test()
    Dim colValues As New Collection
    Dim colGroup As New Collection
    Dim i As Integer
    Dim idx As Integer
    Dim r As Range
    Dim valueCount As Integer
    Dim s As Worksheet
    Dim TargetValue As Double
    Dim diff As Double
    Dim minmaxdiff As Double
    Dim prediff As Double
    Dim ret As String
    Dim divCount As Integer
    Dim loopCount As Long
    '対象シート
    Set s = Worksheets("Sheet1")
    '設定値取得
    divCount = s.Range("B2").Value
    loopCount = s.Range("C2").Value
    '対象となる値リスト取得
    For Each r In s.Range("A2:A" & s.Range("A" & s.Rows.Count).End(xlUp).Row)
        colValues.Add r.Value
    Next
    '値を保持する枠組み生成
    For i = 1 To divCount
        colGroup.Add New Collection
    Next
    '適当に割り振る
    valueCount = colValues.Count
    For i = 0 To valueCount - 1
        idx = i Mod colGroup.Count + 1
        colGroup(idx).Add pickup(colValues)
    Next
    '目標とする値
    TargetValue = GetTargetValue(colGroup)

    '初期化
    prediff = 9 ^ 9
    diff = 0
    '試行回数分繰り返し
    For i = 1 To loopCount
        '最も目標値から外れたグループを判別
        idx = GetChangeIndex(colGroup, TargetValue)
        'Debug.Print idx & vbTab & ToString(colGroup)
        '処理対象とするグループがあるなら
        If idx > 0 Then
            '値の入れ換えを行なう
            If Not ChangeValues(colGroup, TargetValue, idx, i) Then
                'ためし終わった？
                Exit For
            End If
        End If
        '目標との差の合計を取得する
        diff = GetSumAbsDiff(colGroup, TargetValue)
        '今回の差が前回最適解よりも縮んでいたら最適解として保持
        If diff < prediff Then
            prediff = diff
            '20100930 最小と最大の差を付け足す
            'ret = "差の合計:" & Format(diff, "@@@@") & " 目標値:" & Format(TargetValue, "@@@@") & " 結果:" & ToString(colGroup)
            minmaxdiff = GetMinMaxDiff(colGroup)
            ret = "差の合計:" & Format(diff, "@@@@") & " 最小と最大の差:" & Format(minmaxdiff, "@@@@") & " 目標値:" & Format(TargetValue, "@@@@") & " 結果:" & ToString(colGroup)
        End If
        '全てが目標値になったなら終わる
        If diff = 0 Then
            Exit For
        End If
    Next
    '最終的に得られた解を提示
    'Debug.Print ret
    s.Range("D" & s.Range("D" & s.Rows.Count).End(xlUp).Row + 1).Value = ret
    'MsgBox "処理完了" & vbCrLf & ret
End Sub
'値リストからランダムに取り出す
Private Function pickup(ByRef values As Collection) As Double
    Static blnInit As Boolean
    Dim idx As Integer
    Dim ret As Double
    If Not blnInit Then
        Randomize
        blnInit = True
    End If
    idx = Int(Rnd * values.Count) + 1
    ret = values(idx)
    values.Remove idx
    pickup = ret
End Function
'目標値を得る
Private Function GetTargetValue(ByRef group As Collection) As Double
    Dim ret As Double
    Dim obj As Collection
    ret = 0
    For Each obj In group
        ret = ret + GetSum(obj)
    Next
    ret = ret / group.Count
    GetTargetValue = ret
End Function
'目標値との差の絶対値の合計を得る
Private Function GetSumAbsDiff(ByRef group As Collection, ByVal target As Double) As Double
    Dim ret As Double
    Dim obj As Collection
    ret = 0
    For Each obj In group
        ret = ret + Abs(target - GetSum(obj))
    Next
    GetSumAbsDiff = ret
End Function
'20100930 グループの合計値の最大と最小の差を得る
Private Function GetMinMaxDiff(ByRef group As Collection) As Double
    Dim ret As Double
    Dim groupSum As Double
    Dim groupMin As Double
    Dim groupMax As Double
    Dim obj As Collection
    '初期化
    ret = 0
    groupMin = 9 ^ 9
    groupMax = 0
    For Each obj In group
        groupSum = GetSum(obj)
        '最小値を保持
        If groupMin > groupSum Then
            groupMin = groupSum
        End If
        '最大値を保持
        If groupMax < groupSum Then
            groupMax = groupSum
        End If
    Next
    ret = groupMax - groupMin
    GetMinMaxDiff = ret
End Function
'グループの値の合計を得る
Private Function GetSum(ByRef values As Collection) As Double
    Dim ret As Double
    Dim val As Variant
    ret = 0
    For Each val In values
        ret = ret + val
    Next
    GetSum = ret
End Function
'最も目標値から外れたグループのインデックスを得る
Private Function GetChangeIndex(ByRef group As Collection, ByVal target As Double) As Integer
    Dim ret As Integer
    Dim idx As Integer
    Dim diff As Double
    Dim prediff As Double
    Dim obj As Collection
    ret = 0
    prediff = 0
    For idx = 1 To group.Count
        Set obj = group(idx)
        diff = Abs(target - GetSum(obj))
        If diff > prediff Then
            ret = idx
            prediff = diff
        End If
    Next
    GetChangeIndex = ret
End Function
'1つだけ値を入れ換えて目標値に近づける
'Falseが返った場合は入れ換え不能(入れ換えパターンが尽きたとか)
Private Function ChangeValues(ByRef group As Collection, ByVal target As Double, ByVal baseIndex As Integer, ByVal tryCount As Integer) As Boolean
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim baseValueIndex As Integer
    Dim changeIndex As Integer
    Dim changeValueIndex As Integer
    Dim baseGroup As Collection
    Dim otherGroup As Collection
    Dim targetdiff As Double
    Dim diff As Double
    Dim prediff As Double
    Dim baseValue As Double
    Static dic As Object
    Static blnInit As Boolean
    Dim key As String
    '初期化
    ChangeValues = False
    baseValueIndex = 0
    prediff = 9 ^ 9
    If Not blnInit Then
        Set dic = CreateObject("Scripting.Dictionary")
        blnInit = True
    End If
    If tryCount = 1 Then
        dic.RemoveAll
    End If
    '目標値との差を取得
    targetdiff = target - GetSum(group(baseIndex))
    '自身のグループ内から、差を埋めるに最も適した値の組合せを検索
    Set baseGroup = group(baseIndex)
    For i = 1 To baseGroup.Count
        For j = 1 To group.Count
            '自身のグループは無視
            If j = baseIndex Then
                GoTo NEXT_INDEX
            End If
            Set otherGroup = group(j)
            For k = 1 To otherGroup.Count
                diff = targetdiff - (otherGroup(k) - baseGroup(i))
                '求める差に最も近いもののIndexを保持
                If Abs(diff) < Abs(prediff) Then
                    key = i & vbTab & j & vbTab & k & vbTab & otherGroup(k) & vbTab & baseGroup(i)
                    If dic.Exists(key) Then
                        '既に入れ換えたパターンは無視する？大丈夫？
                        dic.Item(key) = dic.Item(key) + 1
                        If dic.Item(key) = 7 Then
                            dic.Remove key
                        End If
                    Else
                        dic.Add key, 1
                        baseValueIndex = i
                        changeIndex = j
                        changeValueIndex = k
                        prediff = diff
                    End If
                End If
            Next
NEXT_INDEX:
        Next
    Next
    '入れ換え対象について入れ換える
    If baseValueIndex > 0 Then
        baseValue = group(baseIndex)(baseValueIndex)
        group(baseIndex).Remove baseValueIndex
        group(baseIndex).Add group(changeIndex)(changeValueIndex)
        group(changeIndex).Remove changeValueIndex
        group(changeIndex).Add baseValue
        ChangeValues = True
    End If
End Function
'結果文字列生成
Private Function ToString(ByRef group As Collection) As String
    Dim ret As String
    Dim strWk As String
    Dim obj As Collection
    Dim val As Variant
    Dim dblSum As Double
    ret = ""
    For Each obj In group
        strWk = ""
        dblSum = 0
        For Each val In obj
            dblSum = dblSum + val
            strWk = strWk & "," & val
        Next
        ret = ret & "/" & Mid(strWk, 2) & "(" & dblSum & ")"
    Next
    ToString = Mid(ret, 2)
End Function
'↑↑↑ここまで↑↑↑
　
こんな感じで出ます
試行結果
差の合計: 116 最小と最大の差:  58 目標値: 529 結果:155,250,145(550)/232,115,190(537)/190,250,118(558)/250,250(500)/250,250(500)
差の合計: 116 最小と最大の差:  58 目標値: 529 結果:250,145,155(550)/232,190,115(537)/250,118,190(558)/250,250(500)/250,250(500)
差の合計: 116 最小と最大の差:  58 目標値: 529 結果:118,250,190(558)/115,232,190(537)/145,250,155(550)/250,250(500)/250,250(500)
差の合計: 116 最小と最大の差:  58 目標値: 529 結果:115,232,190(537)/250,155,145(550)/250,118,190(558)/250,250(500)/250,250(500)
差の合計: 116 最小と最大の差:  58 目標値: 529 結果:145,155,232(532)/250,190,115(555)/250,118,190(558)/250,250(500)/250,250(500)
　
差の合計がいらないなら、
'20100930 最小と最大の差を付け足す
と言うコメントの辺りを見てください。
    ret = "差の合計:" & Format(diff, "@@@@") & " 最小と最大の差:" & Format(minmaxdiff, "@@@@") & " 目標値:" & Format(TargetValue, "@@@@") & " 結果:" & ToString(colGroup)
これを
    ret = " 最小と最大の差:" & Format(minmaxdiff, "@@@@") & " 目標値:" & Format(TargetValue, "@@@@") & " 結果:" & ToString(colGroup)
こうしたりすれば試行結果の表現を編集出来ます。
　
与えられたデータでしか動かしてないので、バグってたらごめんなさい。
（ご近所PG）

---

 ご近所PGさん、お世話になっております。

 完璧です。理想どおりです。
 ご丁寧に教えて頂きまして本当に感謝しております。
 他のデータでも試してみましたが、問題なく動きました。

 一年近く何の問題もなく利用させて頂いておりましたが、
 今回のような特殊なケースが出てきて悩んでおりました。

 また図々しいリクエストがあるかもしれませんが、
 その時はどうぞよろしくお願いいたします。

 本当にありがとうございました！

 （54-71）

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.