ソルバーによるシフト表自動作成

Private Sub cmdGoSolver_Click() ' ' ソルバー実行 ' SolverOk SetCell:="目的セル", MaxMinVal:=2, ValueOf:=0, ByChange:="変化させるセル", _ Engine:=3, EngineDesc:="Evolutionary" SolverSolve End Sub Private Sub cmdInit_Click() 'ソルバー実行 Range("変化させるセル").ClearContents Call 予約転記 End Sub Private Sub cmdReallocate_Click() '均等再配置実行 If Range("目的セル") > 0 Then Range("目的セル").Activate MsgBox "再度、初期化→ソルバー実行、を行ってみて下さい。", vbOKOnly, "過不足が０になっていません。" Exit Sub End If cmdStop.Enabled = True Call reAllocate("変化させるセル", "条件セル", "最小化セル") '均等再配置 cmdStop.Enabled = False End Sub

ソルバーの基本的なモデルを設定します。

マウスを使った操作では、[データ] | [分析] グループの [ソルバー] をクリックした後、[ソルバー : パラメーター設定] ダイアログボックスのオプションを指定することに相当します。

SolverOk(SetCell, MaxMinVal, ValueOf, ByChange,Engine, EngineDesc)

SetCell 省略可能です。バリアント型 (Variant) の値を使用します。作業中のワークシートの単一セルへの参照を指定します。[ソルバー : パラメーター設定] ダイアログボックスの [目的セル] ボックスに相当します。

MaxMinVal 省略可能です。バリアント型 (Variant) の値を使用します。[ソルバー : パラメーター設定] ダイアログボックスの [最大値]、[最小値]、[値] に相当します。

MaxMinVa 設定

1 最大化

2 最小化

3 値と一致

ValueOf 省略可能です。バリアント型 (Variant) の値を使用します。引数 MaxMinVal に 3 を指定した場合は、目的セルの値の目標値を必ず指定してください。

ByChange 省略可能です。バリアント型 (Variant) の値を使用します。目的セルの値が目標値に到達するまで変化させる、セルまたはセル範囲への参照を指定します。
　　[ソルバー : パラメーター設定] ダイアログボックスの [変化させるセル] に相当します。

Engine 省略可能です。バリアント型 (Variant) の値を使用します。問題の解決に使用する解決方法として、Simplex LP 方法の場合は 1、GRG Nonlinear 方法の場合は 2、Evolutionary 方法の場合は 3 を指定します。
　　[ソルバーのパラメーター] ダイアログボックスの [解決方法の選択] ボックスの一覧に相当します。

ByChange 省略可能です。バリアント型 (Variant) の値を使用します。問題の解決に使用する解決方法を文字列 ("Simplex LP"、"GRG Nonlinear"、または "Evolutionary") として指定する代替方法です。
　　[ソルバーのパラメーター] ダイアログボックスの [解決方法の選択] ボックスの一覧に相当します。

Option Explicit Const 収束判定値 = 0.01 Dim flg中止 As Boolean 'flg中止判定用の変数 Sub reAllocate(範囲セル As String, 条件セル As String, 最小化セル As String) ' 均等再配置 '---------------------- '変数 '---------------------- Dim rngShift As Range '選択範囲 Dim SigmaSum As Double '分散計 Set rngShift = Range(範囲セル) '---------------------- '開始 '---------------------- SigmaSum = 99999 '分散初期値 '---------------------- '作業変数 '---------------------- Dim r, c, r2 As Long Dim n As Long Dim tmpSigmaSum As Double tmpSigmaSum = SigmaSum For n = 1 To 10 '繰り返し回数 For c = 1 To rngShift.Columns.Count '選択範囲の列数 For r = 1 To rngShift.Rows.Count '選択範囲の行数 For r2 = r + 1 To rngShift.Rows.Count '----------------------------- DoEvents If flg中止 Then GoTo MyAbort End If '----------------------------- Call MySwap(rngShift(r, c), rngShift(r2, c)) 'セル入れ替え If Range(条件セル).Value <> 0 Then '条件を満たすか？ Call MySwap(rngShift(r, c), rngShift(r2, c)) '満たさない→戻す Else Dim tmp tmp = Range(最小化セル).Value '最小値取り出し If tmp < SigmaSum Then '値更新？ SigmaSum = tmp '新たな最小値とする Else Call MySwap(rngShift(r, c), rngShift(r2, c)) '戻す End If End If Next r2 Next r Next c If Abs(tmpSigmaSum - SigmaSum) < 収束判定値 Then Exit For '収束 tmpSigmaSum = SigmaSum Next n '-------------------------------------- '完了 '-------------------------------------- GoTo MyEnd MyAbort: MyEnd: End Sub Private Sub MySwap(Rng1 As Range, Rng2 As Range) '----------------- 'セルデータ入替 '----------------- Dim tmp As Variant tmp = Rng1.Value Rng1.Value = Rng2.Value Rng2.Value = tmp End Sub Private Function IsRange(RangeName As String) As Boolean ' 範囲名の正当性チェック On Error GoTo MyEnd IsRange = False If Range(RangeName).Address <> "" Then IsRange = True 'アドレスを取得できたら正しい！ MyEnd: On Error GoTo 0 End Function

0	ソルバーによって解が見つかりました。すべての制約条件と最適化条件を満たしています。
1	ソルバーによって現在の解に収束されました。すべての制約条件を満たしています。
2	現在の解の精度を上げることはできません。すべての制約条件を満たしています。
3	反復回数が上限に達し、処理が中止されました。
4	目的セルの値が収束しません。
5	実行可能解が見つかりませんでした。
6	ユーザーの要求によってソルバーが停止しました。
7	この LP ソルバーに必要な線形条件が満たされていません。
8	問題が大きすぎるため、ソルバーで処理できません。
9	目的セルまたは制約条件セルの値でエラーが発生しました。
10	指定された制限時間に達し、処理が中止されました。
11	メモリ不足のため、問題を解決できません。
13	モデルでエラーが発生しました。すべてのセルと制約条件が正しく指定されていることを確認してください。
14	ソルバーによって公差内で整数解が見つかりました。すべての制約条件を満たしています。
15	実行可能 [整数] 解の数が上限に達し、処理が中止されました。
16	実行可能 [整数] 子問題の数が上限に達し、処理が中止されました。
17	大域解に確率収束しました。
18	すべての変数に上限と下限が必要です。
19	バイナリ制約条件または alldifferent 制約条件で、変数の範囲が競合しています。
20	変数の上限と下限には、実行可能解を使用できません。

関連