[[20130110150140]]　『自動分配』（窓際将軍）　ページの最後に飛ぶ

『自動分配』（窓際将軍）
ある品を分配することでおたずねします。
簡単な物に例えますが、あめ玉が１００個あります。
この飴を２０人で適当に分けます。分ける条件として上限１０個、下限５個とします。
Aさん１０個、Bさん６個、Cさん5個、Dさん８個、Eさん５個・・・・といった具合に適当に100個を分けることをご教授願います。

 命題として不適当では？
20人×5個＝100個になってしまうので、下限５個均等に分けるしかありません。
（みやほりん）

同感。全員5個ずつで、5個*20人=100個。これ以外の分配方法は無いでしょう。

個数の件は置いておいて、「適当」というのがランダムで、という意味ならば、VBAを使い、
Rnd関数で20人分の個数を作成。20人分の合計を計算し、個数が目標に一致しないならば
また分配しなおし…、というのが簡単かと思う。

(???)

 シート上で計算する簡単な例だけ。
B2に
　=ROUND(RAND()*5+5,0)
これを右方向に人数分コピーします。
さらにコピーしたセルを下方向に適当な行数（スクロール無しで見れるくらい）コピーします。
A2に　=SUM(B2:?2) （?は人数分コピーした列番号）でこれも上記の行数分コピーします。
　
A列SUM関数で飴玉の個数に一致する行を探します。
なかったらF9キーで再計算させるとそのうち一致すると思われます。
　
（みやほりん）

こんな難しい質問は無理と思う。
???が云われている通りです。
(？？？？？)

 後で素晴らしいコードが提示されるかと思いますが
 挑戦してみたので載せてみます～
 新規ブックでどうぞ。テストそのまま、E3から記載するようになってます。

 配列は二次元にすればそのまま転記出来るとか
 エラー処理してないとか、場所を明示記載してないとか
 色々ありますけど、一応動く、程度で。（くろたろう）

 Option Explicit

 Sub test()
 Dim myNum As Long, mytgtNum As Long, myMax As Long, myMin As Long
 Dim buf As Variant, buf2 As Variant
 Dim i As Long
 Dim tmpSum As Double, tmpSum2 As Long
 Dim myflg As Boolean
 Dim tmpTry As Long, maxTry As Long

 myNum = InputBox("個数", , 100)
 mytgtNum = InputBox("分ける人数", , 20)
 myMax = InputBox("上限", , 10)
 myMin = InputBox("下限", , 3)

 maxTry = 1000
 myflg = True
 tmpTry = 1

 ReDim buf(mytgtNum)
 ReDim buf2(mytgtNum)

 Application.ScreenUpdating = False

 Columns(5).Clear

 While myflg And tmpTry <= maxTry
     tmpSum = 0
     For i = 1 To mytgtNum
         buf(i) = Rnd()
         tmpSum = tmpSum + buf(i)
     Next i

     tmpSum2 = 0
     For i = 1 To mytgtNum
         buf2(i) = Application.WorksheetFunction.Max _
             (Application.WorksheetFunction.Min _
             (myMax, Round(buf(i) / tmpSum * myNum, 0)), myMin)
         tmpSum2 = tmpSum2 + buf2(i)
     Next i
     If (tmpSum2 = myNum) Then myflg = False
     tmpTry = tmpTry + 1
 Wend

 If (Not myflg) Then
     For i = 1 To mytgtNum
         Cells(i + 2, 5).Value = buf2(i)
     Next i
 Else
     MsgBox ("もっかいチャレンジして下さいな")
 End If
 Application.ScreenUpdating = True

 End Sub

とりあえず下限3として、私の例。

 Sub test()
    Const iNINZU = 20
    Const iTOTAL = 100
    Const iMAX = 10
    Const iMIN = 3
    Dim i As Long
    Dim iAll As Long
    Dim iDim(iNINZU - 1) As Long

    While iAll <> iTOTAL
        iAll = 0
        For i = 0 To iNINZU - 1
            iDim(i) = Fix(Rnd() * (iMAX - iMIN + 1)) + iMIN
            iAll = iAll + iDim(i)
        Next i
    Wend

    For i = 0 To iNINZU - 1
        Cells(i + 1, "A").Value = iDim(i)
    Next i
End Sub

(???)

 記念参加です。
 (Mook)

 Option Explicit

 Sub Sample()
    Const totalNum = 100  '// 分配個数
    Const personNum = 20  '// 分配人数
    Const maxNum = 10  '// 上限
    Const minNum = 3  '// 下限

    If minNum * personNum > totalNum Then
       MsgBox "下限の数が大きすぎます。"
       Exit Sub
    End If

    If maxNum * personNum < totalNum Then
       MsgBox "上限の数が小さすぎます。"
       Exit Sub
    End If

    Dim objDic
    Set objDic = CreateObject("Scripting.Dictionary")

    Dim pArray()
    ReDim pArray(1 To personNum, 1 To 1)

    Dim i As Long
    For i = 1 To personNum
       pArray(i, 1) = minNum
       objDic(i) = i
    Next

    Dim targetIndex As Long
    Dim tmpKeys
 '// 残った数を上限未満の人に乱数で振り分け
    For i=minNum * personNum + 1 To totalNum
        tmpKeys = objDic.Keys
        targetIndex = Int(Rnd() * UBound(tmpKeys))
        pArray(objDic(tmpKeys(targetIndex)), 1) = pArray(objDic(tmpKeys(targetIndex)), 1) + 1
        If pArray(objDic(tmpKeys(targetIndex)), 1) = maxNum Then objDic.Remove objDic(tmpKeys(targetIndex))
    Next
 '// とりあえず結果はA列に出力
    Range("A1").Resize(personNum, 1) = pArray
 End Sub

 面白そうなので参加～＾０＾
Sub sample()
　
Const num As Long = 100 '個数
Const per As Long = 20  '人数
Const ma As Long = 10   '上限
Const mi As Long = 3    '下限
Dim v, r As Long, m As Long, mm As Long
　
If (per * ma < num) + (per * mi > num) Then
    MsgBox "設定が正しくありません": Exit Sub
End If
　
ReDim v(1 To per, 1 To 1)
v = Evaluate("if(row(1:" & per & "),row(1:1))") '←追加
Randomize
Do
   r = Int(per * Rnd + 1)
   With Application
      If (v(r, 1) < ma) * (.Sum(v) < num) Then v(r, 1) = v(r, 1) + 1
      If .Sum(v) = num Then
         m = .Min(v): mm = .Match(m, v, 0)
         If m >= mi Then Exit Do
         If v(r, 1) > mi Then v(r, 1) = v(r, 1) - 1: v(mm, 1) = v(mm, 1) + 1
      End If
   End With
Loop
Columns(1).Clear
Range("A1:A" & per).Value = v
End Sub
(Jera)

コメント返信：

[ 一覧(最新更新順) ]

[[20130110150140]] 『自動分配』（窓際将軍） ページの最後に飛ぶ

[[20130110150140]]　『自動分配』（窓際将軍）　ページの最後に飛ぶ