| |
▼マナ さん：
>▼westwindow さん：
>
>>1分かかる処理があるとして
>
>
>どんな処理ですか。コードを提示できませんか。
勤務表自動作成の処理の夜勤入力の部分です。宜しくお願い致します。
Sub 夜勤総合入力3() '山登り法による入力
Range("本館全て").Select
y1 = Selection(1).Row '選択範囲の左上の行位置
y2 = Selection(Selection.Count).Row '選択範囲の右下の行の位置
x1 = Selection(1).Column '選択範囲の左上の列位置
x2 = Selection(Selection.Count).Column '選択範囲の右下の列の位置
x4 = Range("勤務表左上").Column - 1 + Day(Range("月末日")) '月末列番号
For x = x1 To x2
Call 山登り法夜勤(x)
Next x
End Sub
Sub 山登り法夜勤(x11) '列指定
Dim 評価値1 As Single
Dim 評価値2 As Single
Dim a
Dim b
Randomize
Randomize
Range("ガレージ範囲").Select
yg1 = Selection(1).Row '選択範囲の左上の行位置
yg2 = Selection(Selection.Count).Row '選択範囲の右下の行の位置
Range("職員と夜勤ガレージ").Select
y11 = Selection(1).Row '選択範囲の左上の行位置
y22 = Selection(Selection.Count).Row '選択範囲の右下の行の位置
y60 = Range("ビット変数夜勤").Row 'チェックランの位置
x60 = Range("ビット変数夜勤").Column
y70 = Range("夜上限回数").Row 'チェックランの位置
x70 = Range("夜上限回数").Column
y80 = Range("夜総数").Row 'チェックランの位置
x80 = Range("夜総数").Column
For i = 1 To 2000 '★★理想数は不明
'skip1:
判定 = 0 '初期化する
'初期セルを決める
x1 = x11
y1 = WorksheetFunction.RandBetween(y11, y22)
x2 = x11
y2 = WorksheetFunction.RandBetween(y11, y22)
a = Cells(y1, x11)
b = Cells(y2, x11)
a_1 = Cells(y1, x11 + 1)
a_2 = Cells(y1, x11 + 2)
b_1 = Cells(y2, x11 + 1)
b_2 = Cells(y2, x11 + 2)
'-------ビット変数を用意する------
If a = "夜ほ" Then
a_bit = "100"
End If
If a = "夜鳥" Then
a_bit = "010"
End If
If a = "夜花虹" Then
a_bit = "001"
End If
If a = "" Then
a_bit = "000"
End If
If b = "夜ほ" Then
b_bit = "100"
End If
If b = "夜鳥" Then
b_bit = "010"
End If
If b = "夜花虹" Then
b_bit = "001"
End If
If b = "" Then
b_bit = "000"
End If
' ----------------交換できるか調べる
aa =
WorksheetFunction.Dec2Bin(WorksheetFunction.Bitand(WorksheetFunction.Bin2Dec
(Cells(y1, x60)), WorksheetFunction.Bin2Dec(b_bit)), 3)
bb =
WorksheetFunction.Dec2Bin(WorksheetFunction.Bitand(WorksheetFunction.Bin2Dec
(Cells(y2, x60)), WorksheetFunction.Bin2Dec(a_bit)), 3)
If a_bit = "000" Then '交換元が空白の時は、どこで
も交換できる
bb = "111"
End If
If b_bit = "000" Then
aa = "111"
End If
If aa = "000" Or bb = "000" Then '交換できないな
らば戻る
GoTo skip1
End If
'--------評価値1 -------------
評価値1 = 夜勤総合評価(x11)
If 評価値1 = 0 Then '評価
１が０なら終了
Exit Sub
End If
'----------交換------------
Cells(y1, x1) = b
Cells(y2, x1) = a
'--------評価値2 -------------
評価値2 = 夜勤総合評価(x11)
'------------------------------------
If Cells(y1, x80) > Cells(y1, x70) Or Cells(y2, x80) >
Cells(y2, x70) Then '上限数をこえていたら元に戻す
Cells(y1, x1) = a
Cells(y2, x1) = b
End If
If 評価値2 = 0 Then '評価が０なら終了
Exit Sub
End If
If 評価値2 < 評価値1 Then '評価が悪いと元に戻す
Cells(y1, x1) = a
Cells(y2, x1) = b
End If
skip1:
Next i
End Sub
|
|
さかな
- 25/1/31(金) 18:02 -
マナ
- 25/1/28(火) 18:15 -
さかな
- 25/1/28(火) 16:50 -
さかな
- 25/1/28(火) 12:04 -
