Option Explicit
Private Sub cmd成功例転記_Click()
Sheets("検証データ").Range("成功例_調整").Copy Destination:=Range("変化させるセル")
End Sub
'--------------------------------------
' ワークシート制御
'--------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
' ワークシートセルの選択位置が変更された場合の処理
'
Dim myCell As Range
Dim tmp
Dim No As Integer
For Each myCell In Target 'はみ出していたら処理しない
If Application.Intersect(Range("不可勤務"), myCell) Is Nothing Then
Unload frm不可勤務
Exit Sub
End If
Next
' 不可勤務内のみを選択した場合の処理
Set rngSelect = Target '選択セル
With frm不可勤務
.Show vbModeless
Dim k As Integer
Dim Kinmus As String
' 選択域の値がすべて同じかを調べる
Kinmus = Target.Cells(1)
For k = 2 To Target.Cells.Count
If Kinmus <> Target.Cells(k) Then '１番目と異なる？
Kinmus = ""
Exit For
End If
Next k
With .ListBox1
For k = 0 To .ListCount - 1 '選択を全て解除
.Selected(k) = False
Next k
tmp = Split(Kinmus, ",") 'カンマ分割
For k = 0 To UBound(tmp)
No = KinmuNo(CStr(tmp(k)))
If No > 0 Then
.Selected(No - 1) = True
End If
Next k
End With
End With
End Sub
'--------------------------------------
' コマンドボタン制御
'--------------------------------------
Private Sub chk前旬列表示_Click()
Application.Goto Reference:="前旬列"
Selection.EntireColumn.Hidden = Not chk前旬列表示.Value
End Sub
Private Sub cmdデータ転記_Click()
'
' 今旬末１週間のデータを先旬に転記
'
If MsgBox("今旬末１週間のデータを先旬に転記します。よろしいですか？", vbOKCancel, "データ転記") = vbOK Then
Dim Col As Integer '今旬末１週間の開始列番号
With Range("変化させるセル")
Col = .Range("a1").Column + .Columns.Count - 7
End With
With Range("前旬")
.Value = .Offset(0, Col - .Column).Value
End With
End If
End Sub
Public Sub cmd勤務色更新_Click()
SetKinmuCellColor ActiveSheet.Range("出力")
End Sub
Private Sub cmd個別実行_Click()
frm個別実行.Show vbModeless
End Sub
Public Sub cmdGo_Click()
'
' 全自動実行
'
Dim StTime As Date, TryCount As Integer
Dim Msg As String, msg_Opt As String
Dim rc As Integer
Dim MaxTimeNoImp As Integer 'ソルバーで解決を続行する最大時間:秒単位
Dim MaxTimeNoImp_Org As Integer '同、退避
TryCount = 1
msg_Opt = "" '追加メッセージ
MaxTimeNoImp_Org = SolverGet(TypeNum:=29) '既存値退避
MaxTimeNoImp = TIME_NO_IMP_INIT '初期値
StTime = DateTime.Time
Do
Range("MSG").Value = DispMsg("確保中…", TryCount, StTime)
初期化 'ソルバー初期化
条件設定_確保
SolverOptions , , , , , , , , , , , , , , , , , , , , MaxTimeNoImp
rc = Solver_Solve(True) '実行
If rc >= 3 Then
msg_Opt = "キャンセル "
Exit Do '中止？
End If
If Val(Range("目標_過不足")) = 0 Then
If Val(Range("条件_確保")) = 0 Then
If chk途中停止.Value Then
If MsgBox("確保成功！" & vbCrLf & vbCrLf & "続けて「勤務日数自動調整」を行いますか？", vbYesNo, "続行確認") = vbNo Then
msg_Opt = "確保成功！"
Exit Do
End If
End If
If 勤務日数自動調整 = 0 Then
If chk途中停止.Value Then
If MsgBox("調整成功！" & vbCrLf & vbCrLf & "続けて「均等最適化」を行いますか？", vbYesNo, "続行確認") = vbNo Then
msg_Opt = "調整成功！"
Exit Do
End If
End If
Range("MSG").Value = "最適化中…"
Call reAllocate("変化させるセル", "条件_最適化", "目標_最適化") '均等再配置
msg_Opt = "完了"
Exit Do
End If
End If
End If
TryCount = TryCount + 1 '試行回数
If MaxTimeNoImp < TIME_NO_IMP_MAX Then MaxTimeNoImp = MaxTimeNoImp + 15
Loop
MyEnd:
'--------------------------------------
'終了
'--------------------------------------
' SolverOptions , , , , , , , , , , , , , , , , , , , , MaxTimeNoImp_Org '復元
SetKinmuCellColor ActiveSheet.Range("出力") '勤務色更新
Msg = DispMsg(msg_Opt, TryCount, StTime)
Range("MSG").Value = Msg
MsgBox "処理終了！" & vbNewLine & vbNewLine & Msg, , "終了"
End Sub
Public Function 勤務日数自動調整() As Integer
Dim i As Integer
Dim Msg As String
条件設定_日数調整
Msg = "調整不良！"
For i = 1 To 10
Range("MSG").Value = "調整中…" & i
DoEvents
If SolverSolve(True) >= 3 Then
Msg = "中止！"
Exit For '実行
End If
If Range("目標_予定数差") = 0 Then
Msg = "調整完了！"
Exit For
End If
Range("MSG").Value = "ランダム入替中…"
Call randomReAllocate("変化させるセル", "条件_調整", 3) 'ランダム入れ替え
Next i
Range("MSG").Value = Msg
勤務日数自動調整 = Range("目標_予定数差")
End Function
Private Function DispMsg(msg_Opt As String, TryCount As Integer, StTime As Date)
DispMsg = msg_Opt & TryCount & "回目 " & Format(DateTime.Time - StTime, "hh:nn:ss")
End Function
'----------------------------------------------
' 初期化
'----------------------------------------------
Public Sub 初期化() '初期化
Application.Calculation = xlCalculationAutomatic
Range("変化させるセル").ClearContents
Call 予約転記
SetKinmuCellColor ActiveSheet.Range("出力") '出力色
DoEvents
End Sub
'----------------------------------------------
' 条件設定
'----------------------------------------------
Public Sub 条件設定_確保()
' 確保条件
SolverReset '既定値にリセット
SolverOk SetCell:=Range("目標_過不足"), MaxMinVal:=2, ByChange:=Range("変化させるセル") '過不足を最小化＝要員数に一致させる
SolverAdd CellRef:=Range("条件_確保"), Relation:=2, FormulaText:=0 '必須条件 = 0
Call 共通条件追加
End Sub
Public Sub 条件設定_日数調整()
' 勤務日数自動調整条件
SolverReset '規定値にリセット
SolverOk SetCell:=Range("目標_予定数差"), MaxMinVal:=2, ValueOf:=0, ByChange:=Range("変化させるセル")
SolverAdd CellRef:=Range("条件_調整"), Relation:=2, FormulaText:=0 '調整条件 = 0
Call 共通条件追加
End Sub
Private Sub 共通条件追加()
' SolverOptions Precision:=0.001, Convergence:=0.001
SolverOptions Precision:=Val(Range("設定値_精度")), Convergence:=Val(Range("設定値_収束値"))
SolverAdd CellRef:=Range("変化させるセル"), Relation:=1, FormulaText:=Range("勤務最大値") '変化させるセル 以下
SolverAdd CellRef:=Range("変化させるセル"), Relation:=4 '変化させるセル 整数
End Sub
Public Function Solver_Solve(Optional boolHideDialog As Boolean = False) As Integer
'
' ソルバー実行
'
' boolHideDialog：ダイアログを非表示 True:非表示 False:表示
' 戻り値：SolverSolveからの戻り値
'
' Range("集計").Value = False '集計計算オフ
Solver_Solve = SolverSolve(boolHideDialog) '実行
' Range("集計").Value = True '集計計算オン
End Function