[VBA]指定範囲の値に指定人数の担当を割り振る

質問

こちらの識者の方々にはいつもお世話になっています。
VBAの質問です。

環境は下記になります。
OS=windows7 pro 64bit
Office=Excel2010(14.0.7128.5000)

・やりたいこと
VBAを使用して指定範囲の数値の合計(a)を求め、aを指定の値(b)で割った数値の近似値をbの各値に割り振る

日本語にすると難しいので図を見ていただきたいのですが、
担当の人数がB1（毎日変わります）
B6:B16の範囲の合計がB2（毎日変わります）、
B1/B2の値がB3となります。
このあたりはsumやaverageで求めればよいのですが、
4人の担当に対して、おおよそ各項目の個数の合計が似た値となるように
C1:C16に番号を割り振りたいのです。
（C1:C16の番号の最大値がB1となるように）
このようなことがVBAで可能でしょうか？
高校生のころ勉強した記憶がそこはかとなくあるのですが、思い出せず。

もしよろしければコードをご教授いただけますでしょうか。

質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。

回答No.5

keithin

ソルバーを使って解かせれば、８５，８５，８５，８６の組み合わせをエクセルが勝手に計算してくれます。
ただしこの問題ではエボリューショナリを指定する必要がありますが。

もちろんマクロを使い、ソルバーをマクロで操作しても構いません。

準備：
Ｄ列に担当名１，２，３，４を列記
Ｅ列に
=SUMIF(C:C,D2,B:B)
以下コピーを準備
Ｆ２：
=(E2-B$3)^2
以下コピーを準備

Ｆ６：
=SUM(F2:F5)

目的セルはＦ６を最小にする
変数セルはＣ６：Ｃ１６を指定する
制約条件は
Ｃ６：Ｃ１６＞＝１
Ｃ６：Ｃ１６＜＝４
Ｃ５：Ｃ１６＝int（整数）
を設定、解決方法の選択はエボリューショナリ―にして解決する。

回答No.4

kkkkkm

No3です。

番号と人数の最終照合をするように変更したものです。 Example()のほうだけ変更してます。ただ、どちらにしてもこのやり方では、質問の画像にあるような最適解は出ないので採用しがたいですよね(^^;

Sub Example()
Dim i As Long, MinValue As Long, k As Long, BRow As Long, TRow As Long
Dim Total As Long, MenNo As Integer, Multiplier As Single

Multiplier = 0.9
TRow = 6
BRow = Cells(Rows.Count, "B").End(xlUp).Row
Do
Total = 0
MenNo = 1
MinValue = Range("B3").Value * Multiplier
Range(Cells(TRow, "C"), Cells(1000, "C")).ClearContents
For i = BRow To TRow Step -1
Total = Total + Cells(i, "B").Value
If Total > MinValue Then
If Cells(i, "C").Value <> "" Then
Exit For
ElseIf Cells(i, "B").Value > MinValue Then
Cells(i, "C").Value = MenNo
Total = 0
MenNo = MenNo + 1
End If
Else
Call Under(Total, MenNo, TRow, MinValue, i)
End If
Next
Multiplier = Multiplier + 0.1
TRow = 6
Loop Until Range("B1").Value = Application.WorksheetFunction.Max(Range(Cells(TRow, "C"), Cells(1000, "C")))
End Sub

回答No.3

kkkkkm

No2です。

番号と人数の最終照合はしていないので、データ数が多いと番号が人数より多くなります。
実際のデータで多くなった場合

MinValue = Range("B3").Value * 0.9

の0.9を0.95とかに調整してください。この0.9がなんの根拠もないので強引なものになってます。すみません。

回答No.2

kkkkkm

たぶん、ちゃんとしたアルゴリズムがあるのかもしれませんが、知らないので、強引に以下のようなものを作ってみました。よろしければ試してみてください。

B列の個数を昇順にしてから実行してみてください。B3に平均があるものとして考えています。

Sub Example()
Dim i As Long, MinValue As Long, k As Long, BRow As Long, TRow As Long
Dim Total As Long, MenNo As Integer

BRow = Cells(Rows.Count, "B").End(xlUp).Row
Range(Cells(5, "C"), Cells(1000, "C")).ClearContents
TRow = 6
Total = 0
MenNo = 1
MinValue = Range("B3").Value * 0.9

For i = BRow To TRow Step -1
Total = Total + Cells(i, "B").Value
If Total > MinValue Then
If Cells(i, "C").Value <> "" Then
Exit For
ElseIf Cells(i, "B").Value > MinValue Then
Cells(i, "C").Value = MenNo
Total = 0
MenNo = MenNo + 1
End If
Else
Call Under(Total, MenNo, TRow, MinValue, i)
End If
Next
End Sub

Sub Under(ByRef Total As Long, ByRef MenNo As Integer, ByRef TRow As Long, ByRef MinValue As Long, ByRef i As Long)
Total = Total + Range("B" & TRow).Value
If Cells(TRow, "C").Value = "" Then
If i = TRow Then
Cells(TRow, "C").Value = MenNo - 1
Else
Cells(TRow, "C").Value = MenNo
Cells(i, "C").Value = MenNo
If Total > MinValue Then
Total = 0
MenNo = MenNo + 1
TRow = TRow + 1
Else
TRow = TRow + 1
Call Under(Total, MenNo, TRow, MinValue, i)
End If
End If
End If
End Sub

回答No.1

kkkkkm

担当　2
合計　76
平均　38

りんご　20
バナナ　6
みかん　50

のような場合

りんご　20　1
バナナ　　6　1
みかん　50　2

でいいのでしょうか。

補足

はい、あくまで可能な限りの近似値で問題ありません。