Option Explicit

Const 収束判定値 = 0.01
Const NMAX = 10         '均等再配置回数


Sub reAllocate(範囲セル As String, 条件セル As String, 最小化セル As String)

' 最適化　－　「条件セル」の値が０の状態を維持しながら、
' 　　　　　　「最小化セル」の値が最小になるようにセル値を再配置

    Application.ScreenUpdating = False '画面更新停止　－　速度向上な為
    
    '----------------------
    '変数
    '----------------------
    Dim rngShift As Range   '選択範囲
    Dim SigmaSum As Double  '分散計
    
    Set rngShift = Range(範囲セル)

    '----------------------
    '作業変数
    '----------------------
    
    Dim c1 As Integer, r1 As Integer, r2 As Integer
    Dim n As Long
'    Dim blRc As Boolean
    
    Dim tmpSigmaSum As Double
    
    SigmaSum = Range(最小化セル)
        
    For n = 1 To NMAX '繰り返し回数
        For c1 = 1 To rngShift.Columns.Count        '範囲の列数
            
            Application.StatusBar = "最適化中…" & c1 & "/" & rngShift.Columns.Count & " " & n & "/" & NMAX   'ステータスバーに進行状況表示
                    
            For r1 = 1 To rngShift.Rows.Count        '範囲の行数
                If rngShift(r1, c1) <> 0 Then            '勤務？
                    For r2 = 1 To rngShift.Rows.Count
                        If rngShift(r1, c1) <> rngShift(r2, c1) Then '２つのセル値が異なる？
                            Call MySwap(rngShift(r1, c1), rngShift(r2, c1))      'セル値を入れ替えて見る
                            If rngShift(r1, c1) = 0 Or rngShift(r2, c1) = 0 Then
                                '片方が休み
                                If IsChangeNext(rngShift, c1, r1, r2, SigmaSum, Range(最小化セル), Range(条件セル)) = False Then
                                    '２つ目交換不可、または値の更新無しの場合
                                    Call MySwap(rngShift(r1, c1), rngShift(r2, c1))     '戻す
                                End If
                            Else
                                '両方が勤務
                                If Range(条件セル) = 0 Then '交換可
                                    Dim tmp
                                    tmp = Range(最小化セル).Value
'                                    If Not IsNumeric(tmp) Then GoTo MyENd
                                    If tmp < SigmaSum Then          '値更新？
                                        SigmaSum = tmp              '新たな最小値とする
                                    Else
                                        Call MySwap(rngShift(r1, c1), rngShift(r2, c1)) '戻す
                                    End If
                                Else
                                    Call MySwap(rngShift(r1, c1), rngShift(r2, c1))     '戻す
                                End If
                            End If
                        End If
                    Next r2
                End If
            Next r1
        Next c1

        If Abs(tmpSigmaSum - SigmaSum) < 収束判定値 Then Exit For '収束
        tmpSigmaSum = SigmaSum
        
    Next n

    '--------------------------------------
    '完了
    '--------------------------------------
MyENd:
    
    Application.StatusBar = ""
    Application.ScreenUpdating = True '画面更新再開
    
End Sub

Private Function IsChangeNext(rngShift As Range, c As Integer, r1 As Integer, r2 As Integer, _
                              ByRef evalMin As Double, _
                              dsprCell As Range, cndtCell As Range) As Boolean
'---------------------------------------------------
' 処理
'   別の日の同一行(r1,r2)を交換して見て
'   交換可能の場合
'     分散値最低を比較し更新：交換、更新無：元の状態
'     evalMin：分散値を返す　リターン値：TRUE
'   交換不可の場合
'     evalMin：元の値　　　　リターン値：FALSE
'---------------------------------------------------
' 入力
'   rngShift:対象シフト範囲
'
'   １つ目の交換
'      c :列
'      r1:行１
'      r2:行２
'      evalMin:現在の最低値　　　参照渡し変数
'      dsprCell:評価分散値セル
'      cndtCell:条件セル
'
' 戻り値
'   True :交換可　　２つ目：交換済み
'   False:交換不可　２つ目：元の状態

    IsChangeNext = False    '既定値：交換不可
    
    Dim c2 As Integer
    Dim tmp
    
    For c2 = 1 To rngShift.Columns.Count
        If c2 <> c Then '別の列（日）？
            If rngShift.Cells(r1, c) = 0 And rngShift.Cells(r2, c2) <> 0 Then  'c2 r1:休み r2:勤務？
               Call MySwap(rngShift(r1, c2), rngShift(r2, c2))  '２つ目を交換
                If Val(cndtCell.Value) <> 0 Then                '条件を満たさない？
                    Call MySwap(rngShift(r1, c2), rngShift(r2, c2))    '　→　戻す
                Else
                    tmp = CDbl(dsprCell.Value) '評価値
                    If tmp < evalMin Then      '値更新？
                        evalMin = tmp          '新たな最小値とする
                        IsChangeNext = True    '交換可！
                    Else
                        Call MySwap(rngShift(r1, c2), rngShift(r2, c2))    '更新しない　→　戻す
                    End If
                End If
            End If
        End If
    Next c2

End Function


Sub randomReAllocate(範囲セル As String, 条件セル As String, 回数 As Integer)

' ランダム入替
'
' 　処理：「条件セル」の値を０に維持しながら「範囲セル」の値をランダムに入れ替える

    Application.ScreenUpdating = False '画面更新停止
    
    '----------------------
    '変数
    '----------------------
    Dim rngShift As Range   '選択範囲
    
    Set rngShift = Range(範囲セル)
    
    '----------------------
    '開始
    '----------------------
    
    Dim r, c, r2 As Long
    Dim n As Long
        
    For n = 1 To 回数 '繰り返し回数
        Application.StatusBar = "ランダム入替中…" & n & "/" & 回数   'ステータスバーに進行状況表示
        For c = 1 To rngShift.Columns.Count         '選択範囲の列数
            For r = 1 To rngShift.Rows.Count        '選択範囲の行数
                For r2 = r + 1 To rngShift.Rows.Count
                    Call MySwap(rngShift(r, c), rngShift(r2, c))        'セル入れ替え
                    If Val(Range("条件_調整").Value) <> 0 Then        '条件を満たさない？
                        Call MySwap(rngShift(r, c), rngShift(r2, c))    '　→戻す
                    End If
                Next r2
            Next r
        Next c
    Next n

    '--------------------------------------
    '完了
    '--------------------------------------
    Application.StatusBar = ""
    Application.ScreenUpdating = True '画面更新再開
    
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



Public Sub 予約転記()
'
' 予約勤務を数値に変換して「変化させるセル」に転記
'
    Application.ScreenUpdating = False  '画面更新停止
    
    Dim r As Integer, c As Integer
    Dim Src
    Src = Range("予約勤務")
    With Range("変化させるセル")
        For r = 1 To .Rows.Count
            For c = 1 To .Columns.Count
                If CStr(Src(r, c)) <> "" Then
                    .Cells(r, c) = CStr(Src(r, c))
                End If
            Next c
        Next r
    End With
    
    Application.ScreenUpdating = True  '画面更新再開
    
End Sub



'------------------------------------------
' サブルーチン
'------------------------------------------

Public Sub SetKinmuCellColor(範囲 As Range)
'
' 指定範囲を勤務に応じたセル色にセット
'
    Application.ScreenUpdating = False  '画面更新停止
    Dim tmp As Range
    For Each tmp In 範囲
        tmp.Interior.Color = KinmuColor(CStr(tmp.Value))
        tmp.Font.Color = KinmuFontColor(CStr(tmp.Value))
    Next
    Application.ScreenUpdating = True  '画面更新再開
End Sub