ここでの改良点

・変化させるセル範囲を、入力氏名数に応じて可変

方法：

　　名前「変化させるセル」の範囲を固定ではなく下記のような数式で設定

　　=OFFSET(変化セル範囲可変!$D$44,0,0,行数,列数)

　　式の意味
　　　　　変化させるセル範囲の左上のセルを起点にし、
　　　　　　　　氏名が入力されている分を行数、
　　　　　　　　日付が設定されている分を列数
　　　　　として、範囲を設定する。
　　　　　行数、列数は名前として定義。

　　これにより、氏名の追加／削除でも、変化させるセル範囲は自動で調整

　　名前の使い方については、「名前の動的定義」を参照


コンパイルエラー発生時

全自動実行

　　SolｖerSolve関数のパラメータ指定により、開始ダイアログを表示せず均等再配置まで全自動で実行
　　中止は｛ＥＳＣ｝キーを押下

その他

・DialogBoxボタン追加：ソルバーのダイアログボックスを表示 SolverOkDialog関数

定義変数名

SolverSolve関数

SolverSolve(UserFinish, ShowRef) UserFinish 省略可能です。バリアント型 (Variant) の値を使用します。
　　True を指定すると、[ソルバー : 探索結果] ダイアログ ボックスを表示せずに結果を返します。
　　False を指定するか省略すると、結果を返し、[ソルバー : 探索結果] ダイアログ ボックスを表示します。
ShowRef 省略可能です。バリアント型 (Variant) の値を使用します。ShowRef 引数として、マクロの名前 (文字列) を渡すことができます。

戻り値

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

GetAsyncKeyState関数

引数で指定したキーの押下状態を返します。

引数：キーコード

詳しくは、ヘルプ　GetAsyncKeyState関数の仕様　を参考にしてください。

Application.ScreenUpdating

Application.ScreenUpdating = False

画面の更新を停止します。True とすると、更新を再開。
画面表示は大変時間を要する処理です。
特に途中経過を見る必要が無い場合、画面の更新を停止すると、処理速度がかなり早くなります。（場合により１０倍以上）

条件付きコンパイル

　　　３２／６４ビット版Ｗｉｎｄｏｗｓへの対応

#If Win64 Then
     Public Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As LongLong
#Else
     Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
#End If

参考：Office 2010 の 32 ビット バージョンと 64 ビット バージョンとの互換性

VBAコード部　変更／追加点のみ

'--------------------------------------
' コマンドボタン制御
'--------------------------------------

Private Sub cmdGo_Click()
'
' 全自動実行
'
    Do
        cmdInit_Click   '初期化
        If SolverDialog(True) >= 3 Then Exit Do '中止？
        If Val(Range("目的セル")) = 0 Then
            Application.ScreenUpdating = False '画面更新停止
            cmdReallocate_Click '均等再配置
            Application.ScreenUpdating = True '画面更新再開
            Exit Do
        End If
    Loop

End Sub

Private Sub cmdInit_Click() 'ソルバー実行
    Range("変化させるセル").ClearContents
End Sub



Private Sub cmdSolverDialog_Click()
'
' ソルバーダイアログ表示
'
    SolverOkDialog SetCell:="目的セル", MaxMinVal:=2, ValueOf:=0, ByChange:="変化させるセル", _
                    engine:=3, EngineDesc:="Evolutionary"

End Sub

Private Sub cmdGoSolver_Click()
'
' ソルバー実行
'
    Call SolverDialog(True)
    
End Sub
Private Function SolverDialog(Optional boolHideDialog As Boolean = False) As Integer
'
' ソルバー実行
'
' 　boolHideDialog：ダイアログを非表示　True:非表示 False:表示
'   戻り値：SolverSolveからの戻り値
'
    Dim rc
    SolverDialog = SolverSolve(boolHideDialog) '実行

    
End Function



Private Sub cmdReallocate_Click()   '均等再配置実行

    If Range("目的セル") > 0 Then
        MsgBox "再度、初期化→ソルバー実行、を行ってみて下さい。", vbOKOnly, "過不足が０になっていません。"
        Exit Sub
    End If
    
    Call reAllocate("変化させるセル", "条件セル", "最小化セル")  '均等再配置

End Sub

Option Explicit

#If Win64 Then
    Public Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As LongLong
#Else
    Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
#End If


Const 収束判定値 = 0.01

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
                    '-----------------------------
                    If (GetAsyncKeyState(vbKeyEscape) And 1) = 1 Then GoTo MyAbort
                    '-----------------------------
                    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

    '--------------------------------------
    '完了
    '--------------------------------------
    MsgBox "均等再配置完了！", , "正常終了"
    
    GoTo MyEnd

MyAbort:
    MsgBox "均等再配置中止！", , "中止"
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

次項では「予約勤務」（指定日に勤務を予約しておく）機能を搭載します。
次第に複雑になってきます。　数式も高度に・・・・・！

関連