[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『平等な当番表』（ゆゆ）
初めまして<(_ _*)>
http://www.excel.studio-kazu.jp/kw/20190727174210.html#Page-Top
こちらの質問を参考に
スタッフの数を10名
掃除の当番が一日に6種類（ABCDEF）
に置き換えマクロを書き換えて実行してみたのですが、同じ人が同じ掃除の場所を連続でやってたり当番に偏りがでてしまうのですが解決方法はありますでしょうか？説明不足でしたら申し訳ありません。
お手数おかけしますが宜しくお願い致します。
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
仕事が5種から6種、スタッフが6人から10人に変わっただけですね？
<当番表 シート 実行前または【ClearResult】を実行して手入力の休だけ残した状態>
行 ___A___ __B__ __C__ __D__ __E__ __F__ __G__ __H__ __I__ __J__ 1 9/26 9/27 9/28 9/29 9/30 10/1 10/2 10/3 10/4 右に続く 2 りんご 休 休 休 3 みかん 休 休 4 いちご 休 休 5 すいか 休 6 めろん 休 7 れもん 休 休 休 8 バナナ 9 キウィ 10 ブドウ 11 チェリ
<当番表 シート 【JobAssign】を実行後> 行 ___A___ __B__ __C__ __D__ __E__ __F__ __G__ __H__ __I__ __J__ 1 9/26 9/27 9/28 9/29 9/30 10/1 10/2 10/3 10/4 右に続く 2 りんご 休 A B C 休 D 休 E F 3 みかん A E (休) B 休 C D 休 A 4 いちご B F (休) D F 休 E 休 D 5 すいか C (休) A 休 B E (休) D E 6 めろん D (休) C E (休) A (休) 休 B 7 れもん E 休 休 休 A B C F (休) 8 バナナ F (休) D F (休) F (休) A (休) 9 キウィ (休) B E (休) C (休) A B (休) 10 ブドウ (休) C F (休) D (休) B C (休) 11 チェリ (休) D (休) A E (休) F (休) C
Type staff
Name As Variant
ScheD As Range
CurrV() As Variant
CurrA As Range '今月担当した当番の種類と数
AccmT As Range
End Type
Sub JobAssign()
Const numOfJobs As Long = 6 'ABCDEF
Const numOfStaffs As Long = 10 '人数
Dim ws当番 As Worksheet
Dim 社員(1 To numOfStaffs) As staff
Dim 連番Ary()
Dim 当日割当管理板() As Boolean '当日割当てた当番を管理
Dim 当番名Ary
Dim idx As Long
Dim JobIdx As Long '当番名のIndex
Dim DateCol As Long
Dim Fewest As Long '最優先キー
Dim sortKey As Long '当日回数<累計割当＜idx
Dim unAssigned As Long '未割当数
連番Ary = Evaluate("row(A1:A" & numOfJobs & ")")
Set ws当番 = Sheets("当番表")
Application.ScreenUpdating = False
Rem 基本データを格納
With ws当番
当番名Ary = .Range("AI1:AP1").Value '当番名配列
For idx = 1 To numOfStaffs
社員(idx).Name = .Cells(idx + 1, "A").Value
Set 社員(idx).ScheD = .Cells(idx + 1, "B").Resize(1, 31)
Set 社員(idx).CurrA = .Cells(idx + 1, "AI").Resize(1, numOfJobs)
Set 社員(idx).AccmT = .Cells(idx + 1, "AQ")
Next idx
'表の集計エリアのタイトルを書き込む
.Range("AH1").Resize(1, 10).Value = [{"合計","A","B","C","D","E","F","予備","調整","調整後"}]
'集計用の数式を埋め込む
.Range("AH2:AO10").ClearContents
.Range("AH2").Resize(numOfStaffs, 1).FormulaR1C1Local = "=SUM(RC[1]:RC[7])"
.Range("AQ2").Resize(numOfStaffs, 1).FormulaR1C1Local = "=SUM(RC[-9],RC[-1])"
.Range("AI2").Resize(numOfStaffs, 7).FormulaR1C1Local = _
"=IF(RC1="""","""",IF(LEFT(R1C,2)=""予備"","""",COUNTIF(RC2:RC33,""*""&R1C&""*"")))"
End With
Rem 割当開始
For DateCol = 1 To 31 '31迄 日付順に決定する
ReDim 当日割当管理板(1 To numOfJobs)
'当日、全社員が休みでないか、または日付データが正しいか、事前確認
If Application.CountIf(ws当番.Cells(2, DateCol + 1).Resize(numOfStaffs), "*休*") < numOfStaffs _
And IsDate(ws当番.Cells(1, DateCol + 1)) Then
'各社員が当日に割当てられた当番の記憶をクリア
For idx = 1 To numOfStaffs
ReDim 社員(idx).CurrV(0 To numOfJobs)
Next idx
'最少当番割当者を決定する. 順位；当日割当数＜累計割当数
unAssigned = numOfJobs '未割当数を初期化
Do While unAssigned > 0
Fewest = 99999999 '仮置き
For idx = 1 To numOfStaffs
With 社員(idx)
If .ScheD(1, DateCol).Value = "" Or .ScheD(1, DateCol).HasFormula Then
sortKey = .CurrV(0) * 100000 + .AccmT(1, 1) * 100 + idx
Fewest = Application.Min(sortKey, Fewest)
End If
End With
Next idx
idx = Fewest Mod 100 '割当てるべきスタッフのIndexをセット
JobIdx = getJob(社員(idx), 連番Ary, 当日割当管理板) '割り当てる当番名Indexを取得する
'割り当てる当番名を数式の形で出力する
社員(idx).ScheD(1, DateCol).Formula = "=""" & 社員(idx).ScheD(1, DateCol) & 当番名Ary(1, JobIdx) & """"
'決定後の処理
社員(idx).CurrV(0) = 社員(idx).CurrV(0) + 1 '当社員の当日担当数をインクリメント
当日割当管理板(JobIdx) = True '決定フラグで埋めて、割当状況を更新
unAssigned = unAssigned - 1 '未割当て残数をディクリメント
Loop
End If
'当日余った人は、強制的に休みにする（表示文字は「(休)」として、手入力の休みとは区別する。
If IsDate(ws当番.Cells(1, DateCol + 1)) Then
On Error Resume Next
ws当番.Cells(2, DateCol + 1).Resize(numOfStaffs).SpecialCells(xlCellTypeBlanks).Value = "=""(休)"""
On Error GoTo 0
End If
Next DateCol
Application.ScreenUpdating = True
End Sub
Private Function getJob(ByRef targetStaff As staff, ByRef 連番Ary, ByRef 当日割当管理板)
Dim JobsInOrder, NN As Long
'担当過少当番順
ReDim JobsAssignedSofar(1 To UBound(連番Ary))
For NN = 1 To UBound(連番Ary)
JobsAssignedSofar(NN) = targetStaff.CurrA(1, NN) * 100 + NN
Next NN
JobsInOrder = Application.Small(JobsAssignedSofar, 連番Ary)
For NN = 1 To UBound(連番Ary)
getJob = JobsInOrder(NN, 1) Mod 100
If 当日割当管理板(getJob) = False Then
Exit Function
End If
Next
If NN > UBound(連番Ary) Then Stop 'あり得ない
End Function
Sub ClearResult() '手入力の休み以外を空白に戻す(振り出しの戻したい時に実行する)
On Error Resume Next
Range("B2:AF12").SpecialCells(xlCellTypeFormulas, 23).Clear
On Error GoTo 0
Range("B2").Select
End Sub
（半平太） 2021/06/14(月) 20:23
お伺いしたいことがあるのですが、休みを入力しマクロを実行した結果
合計 A B C D E F あ 22 2 3 3 3 6 5 い 17 4 3 3 3 2 2 う 11 2 2 2 2 2 1 え 21 3 4 4 3 3 4 お 16 3 3 3 3 2 2 か 22 4 3 4 4 3 4 き 22 3 3 3 4 4 5 く 19 3 4 3 3 3 3 け 17 3 3 3 3 3 2 こ 13 3 2 2 2 2 2
このように「あ」の人だけEFの回数が多く
F E E 休 D D E
上記のように連続して同じ場所を割り当てられてしまうのですが回避する方法はありますでしょうか？
（ゆゆ） 2021/06/14(月) 20:46
そんなにバラつくハズないと思うのですが、、 よっぽど休みが不規則なんですかねぇ‥
こちらで再現テストをしてみます。
下のマクロを実行するとイミディエイトウィンドウに「休」の情報が出るので、 それをコピーして、この掲示板に貼り付けてください。
Sub printOffInfo()
Dim cel As Range, adr
On Error Resume Next
Range("B2:AF12").SpecialCells(xlCellTypeFormulas, 23).Clear
On Error GoTo 0
For Each cel In Range("B2:AF12")
If Not IsEmpty(cel) Then
adr = adr & "," & cel.Address(0, 0) & "=" & cel.Value & ""
End If
Next
Debug.Print adr
End Sub
こんな結果が出るハズです。 ↓ ,B2=休,F2=休,H2=休,F3=休,I3=休,G4=休,I4=休,E5=休,・・・
（半平太） 2021/06/14(月) 23:50
こんばんは！ お邪魔します。。。。
これは、、単に指定休を避けて6人を(休)を含みながらランダムに振り分ければいいのですね？？？？ 乱数は私の趣向なので↓ここから拝借しています。。お気に召さない等の場合はRndに変えてください。。 http://www001.upp.so-net.ne.jp/isaku/mt.html
それから 私のパソコンは64Bitなので32Bitの場合は冒頭のこれ↓ Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As Long これに↓に変えてください。。。論点はそこじゃないんでしょうけど、、、、 'Private Declare Function GetTickCount Lib "kernel32" () As Long
集計はしてませんけど、、比較しやすい様に取り敢えず A13 に書き出す様にしています。。。 まぁ、、何かの参考にして頂けたら幸いです。。。 なお、何分にもずぶのど素人が片手間で書いたコードですのでお気に召さない箇所等は適当にアレンジしていただけますと幸甚です。 では、、では、、おやすみなさいzzzzzzzzzzzzzzzzz
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J]
[1] | |9月26日|9月27日|9月28日|9月29日|9月30日|10月1日|10月2日|10月3日|10月4日
[2] |りんご|休 | | | |休 | |休 | |
[3] |みかん| | | | |休 | | |休 |
[4] |いちご| | | | | |休 | |休 |
[5] |すいか| | | |休 | | | | |
[6] |めろん| | | | | | | |休 |
[7] |れもん| |休 |休 |休 | | | | |
[8] |バナナ| | | | | | | | |
[9] |キウィ| | | | | | | | |
[10]|ブドウ| | | | | | | | |
[11]|チェリ| | | | | | | | |
[12]| | | | | | | | | |
[13]| |9月26日|9月27日|9月28日|9月29日|9月30日|10月1日|10月2日|10月3日|10月4日
[14]|りんご|休 |D |A |F |休 |(休) |休 |F |B
[15]|みかん|D |E |F |C |休 |E |B |休 |(休)
[16]|いちご|B |(休) |E |A |F |休 |(休) |休 |A
[17]|すいか|(休) |(休) |(休) |休 |B |(休) |(休) |B |(休)
[18]|めろん|(休) |A |(休) |B |C |A |C |休 |E
[19]|れもん|(休) |休 |休 |休 |(休) |B |F |(休) |C
[20]|バナナ|E |F |(休) |(休) |E |D |(休) |D |(休)
[21]|キウィ|C |C |D |E |D |C |D |E |(休)
[22]|ブドウ|F |(休) |C |(休) |A |(休) |A |C |F
[23]|チェリ|A |B |B |D |(休) |F |E |A |D
Option Explicit
Sub てすと()
Static MyDic As Object
Dim v As Variant
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim q() As Variant
Dim q1 As Variant
Dim q2 As Variant
Dim n As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim xi As Long
Dim 脱出弾 As Long
Dim MyFlg As Boolean
x = Array("A", "B", "C", "D", "E", "F")
ReDim q(1 To UBound(x) + 1, 1 To 2)
If MyDic Is Nothing Then
Set MyDic = CreateObject("Scripting.Dictionary")
For i = LBound(x) To UBound(x)
MyDic(x(i)) = Empty
Next
Else
q1 = MyDic.Keys
q2 = MyDic.Items
For i = LBound(q, 1) To UBound(q, 1)
q(i, 1) = q1(i - 1)
q(i, 2) = q2(i - 1)
Next
QuickSort q, 2, LBound(q, 1), UBound(q, 1)
For i = LBound(x) To UBound(x)
x(i) = q(i + 1, 1)
Next
End If
v = Sheets("sheet1").Range("A1").CurrentRegion.Resize(11).Value
Randomize
For j = LBound(v, 2) + 1 To UBound(v, 2)
y = Application.Transpose(Application.Index(v, 0, j))
n = UBound(Filter(y, "休", True)) + 1
ReDim z(UBound(v, 1) - 2)
xi = 0
k = 0
For i = LBound(y) To UBound(y) - 1
xi = xi + 1
If y(xi + 1) = "休" Then
z(xi - 1) = "休"
Else
If k <= UBound(x) Then
z(xi - 1) = x(k)
k = k + 1
End If
End If
Next
For i = LBound(z) To UBound(z)
If z(i) = "" Then z(i) = "(休)"
Next
Do
MyFScs z
k = 0
MyFlg = False
For i = LBound(v, 1) + 1 To UBound(v, 1)
If v(i, j) = "休" Then
v(i, j) = "休"
Else
If z(k) <> "休" Then
v(i, j) = z(k)
k = k + 1
Else
k = k + 1
i = i - 1
End If
End If
Next
For i = LBound(v, 1) + 1 To UBound(v, 1)
If (v(i, j) <> "休") * (v(i, j - 1) <> "休") Then
If v(i, j) = v(i, j - 1) Then
MyFlg = True
Exit For
End If
End If
Next
If j >= UBound(x) Then
For i = LBound(v, 1) + 1 To UBound(v, 1)
If v(i, j) <> "休" Then
For xi = j - 1 To j - (UBound(x) - 1) Step -1
If v(i, j) = v(i, xi) Then
MyFlg = True
Exit For
End If
Next
End If
If MyFlg = True Then Exit For
Next
End If
脱出弾 = 脱出弾 + 1
If 脱出弾 > 1000 Then
MsgBox "規程数に達しました。。。" & vbCrLf & _
"休み調整してください。。。。"
Exit Sub
End If
Loop Until MyFlg = False
For i = LBound(v, 1) + 1 To UBound(v, 1)
If MyDic.Exists(v(i, j)) Then MyDic(v(i, j)) = MyDic(v(i, j)) + 1
Next
Next
Sheets("Sheet1").Range("A13").Resize(UBound(v, 1), UBound(v, 2)).Value = v
If IsArray(q1) Then Erase q1
If IsArray(q2) Then Erase q2
Erase v, x, y, z, q
End Sub
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2)
For i = LBound(x, 1) To UBound(x, 1)
y(i + 1, 1) = x(i)
y(i + 1, 2) = Round(Rnd(), 5)
Next
QuickSort y, 2, LBound(y, 1), UBound(y, 1)
For i = LBound(x, 1) To UBound(x, 1)
x(i) = y(i + 1, 1)
Next
Erase y
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As Variant
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
Do
Do While MySAry(i, MySKey) < MySMid
i = i + 1
Loop
Do While MySAry(j, MySKey) > MySMid
j = j - 1
Loop
If i >= j Then Exit Do
For n = MySLBound To MySUBound
MyStmp = MySAry(i, n)
MySAry(i, n) = MySAry(j, n)
MySAry(j, n) = MyStmp
Next
i = i + 1
j = j - 1
Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
（SoulMan） 2021/06/14(月) 23:59
,F2=休,L2=休,M2=休,P2=休,T2=休,W2=休,Y2=休,AA2=休,AE2=休,C3=休,D3=休,E3=休,H3=休,J3=休,L3=休,O3=休,Q3=休,S3=休,V3=休,X3=休,Z3=休,AC3=休,AE3=休,C4=休,D4=休,E4=休,G4=休,H4=休,J4=休,M4=休,N4=休,O4=休,Q4=休,S4=休,U4=休,V4=休,W4=休,X4=休,Z4=休,AB4=休,AC4=休,AE4=休,B5=休,G5=休,I5=休,K5=休,P5=休,R5=休,W5=休,Y5=休,Z5=休,AC5=休,B6=休,I6=休,K6=休,L6=休,M6=休,N6=休,P6=休,R6=休,T6=休,U6=休,V6=休,W6=休,Y6=休,AD6=休,B7=休,E7=休,F7=休,I7=休,P7=休,V7=休,AA7=休,AD7=休,D8=休,G8=休,K8=休,Q8=休,S8=休,Y8=休,AB8=休,AE8=休,B9=休,E9=休,H9=休,K9=休,O9=休,R9=休,T9=休,U9=休,X9=休,AA9=休,AD9=休,C10=休,F10=休,G10=休,J10=休,M10=休,N10=休,R10=休,T10=休,U10=休,X10=休,AA10=休,AB10=休,AD10=休,B11=休,C11=休,D11=休,E11=休,F11=休,G11=休,H11=休,I11=休,J11=休,L11=休,N11=休,O11=休,Q11=休,S11=休,Z11=休,AB11=休,AC11=休
,F2=休,L2=休,M2=休,P2=休,T2=休,W2=休,Y2=休,AA2=休,AE2=休,C3=休,D3=休,E3=休,H3=休,J3=休,L3=休,O3=休,Q3=休,S3=休,V3=休,X3=休,Z3=休,AC3=休,AE3=休,C4=休,D4=休,E4=休,G4=休,H4=休,J4=休,M4=休,N4=休,O4=休,Q4=休,S4=休,U4=休,V4=休,W4=休,X4=休,Z4=休,AB4=休,AC4=休,AE4=休,B5=休,G5=休,I5=休,K5=休,P5=休,R5=休,W5=休,Y5=休,Z5=休,AC5=休,B6=休,I6=休,K6=休,L6=休,M6=休,N6=休,P6=休,R6=休,T6=休,U6=休,V6=休,W6=休,Y6=休,AD6=休,B7=休,E7=休,F7=休,I7=休,P7=休,V7=休,AA7=休,AD7=休,D8=休,G8=休,K8=休,Q8=休,S8=休,Y8=休,AB8=休,AE8=休,B9=休,E9=休,H9=休,K9=休,O9=休,R9=休,T9=休,U9=休,X9=休,AA9=休,AD9=休,C10=休,F10=休,G10=休,J10=休,M10=休,N10=休,R10=休,T10=休,U10=休,X10=休,AA10=休,AB10=休,AD10=休,B11=休,C11=休,D11=休,E11=休,F11=休,G11=休,H11=休,I11=休,J11=休,L11=休,N11=休,O11=休,Q11=休,S11=休,Z11=休,AB11=休,AC11=休
（SoulMan）様
わざわざありがとうございます！試してみます！<(_ _*)>
（ゆゆ） 2021/06/15(火) 00:41
おはようございます。。。 すみません。 既存のコードにこれ↓を追加していただくか？ Dim n As Variant ですが、、、 一応、、怪しげな趣味趣向のコードを削除したものに差し替えておきました。。。m(__)m
それでは、、行ってきます。。。。 （SoulMan） 2021/06/15(火) 05:27
現象、再現しました。m(__)m
ロジックを見直す必要があります・・が、 SoulManさんが別案を出されているので、そちらにお任せします。
（半平太） 2021/06/15(火) 07:52
多分、一番下に 休 があると エラーになるのでちょっと修正しました 度々、すみませんm(_ _)m （SoulMan） 2021/06/15(火) 09:04
（SoulMan）様
無事実行することができました！休みが5人以上いるときエラーがでてきますが問題なく使えます！、、、のですが最初に使っていたマクロより偏りが出てきてしまうのですが、乱数をRndに変更する場合どこを弄ればよろしいでしょうか？
合計 A B C D E F
20 2 3 1 7 3 4
15 5 3 2 1 1 3
11 0 0 2 2 2 5
20 3 2 5 3 3 4
14 6 1 2 4 0 1
20 1 5 4 3 3 4
20 4 3 1 2 6 4
16 4 4 3 2 1 2
14 1 6 3 0 2 2
16 2 3 4 4 2 1
実行するとこのように偏りが出てきてしまうのですが、A〜Fの値を平均にすることは可能でしょうか？
知識がなく申し訳ありません<(_ _*)>
（ゆゆ） 2021/06/15(火) 09:43
ほんと度々すみません ロジックに誤りがありましたので修正しました しかしながらiPhoneからなんで正直よくわかりません 帰ったらゆっくりと見てみますが あきらかなバグがありましたので 改めてお試しください ところで使えないのは乱数の方ですか？ それとも並び替えの方ですか？ 最初のエラーはどの行で出ましたか？
（SoulMan） 2021/06/15(火) 10:16
＞一つだけ質問なのですが、F E E 休 D 休 D E B B のように ＞同じ場所が連続で当たらないようにすることは可能でしょうか？
それもロジックの見直しに含まれます。
休みのデータを見て思ったのは、意外に休む人が多いなぁと言うことと 人によって休む日数が違い過ぎる事ですね。
そうなると、「平等」とは何かを考え直さなければならないと言う気がします。
１．休むのは本人の勝手であり、当番はできるだけ同じ数にすべき ２．休みが多い人は、それに応じて当番数は少なくして上げるべき
どっちなんですかね？
（半平太） 2021/06/15(火) 10:32
いえ、こちらこそ何度ももうしわけありません
乱数の方です！
n = UBound(Filter(y, "休", True)) + 1
If n + UBound(x) + 1 > UBound(v, 1) - 1 Then
MsgBox "指定休に誤りがあります。。。。。"
指定休に誤りがありますとポップアップ表示されるだけなので行はわかりません；；
おそらくこのあたりだと思うのですが。ですが休みの日を4以下にすればエラーはでないのでその点は大丈夫です！
（半平太）様
2ですかね出勤が多い人の仕事場所の偏りをなくしてあげたいです。
今一番したいことは、同じ場所が連続で当たらないようにすることです。
ロジックの見直しということでおそらく今の自分の知識ではできないので、少し参考になるコードを探したり勉強してみます！<(_ _*)>
（ゆゆ） 2021/06/15(火) 10:49
＞少し参考になるコードを探したり勉強してみます！
偉い！ けど、私が考えてあげますよ。(ちょっと構想を練る必要がありそう）
（半平太） 2021/06/15(火) 11:20
取り敢えず、連続したらやり直すコードを追加してみました でもiPhoneからなんでかなり怪しいです それから４人以上は休めない様にしていますのでそれはエラーではないです ４人以上休む場合は、完成した後にジャンケンでもして決めてください ちょっと仕事しますm(_ _)m （SoulMan） 2021/06/15(火) 11:44
考えたみましたが、かなり骨格を変えなければならないかもです。
作れたらアップしますが、ちょっと時間が掛かりそう。
その前にSoulManさんのがワークしてくれるのを期待します。
（半平太） 2021/06/15(火) 13:48
４人の制限を外すために 代入する前に一度シャッフルして 上から順にセットする様にしました
ところで動いてます？(笑)
いかんせんiPhoneなんで限界かな？ （SoulMan） 2021/06/15(火) 14:09
自分でできるようになってみたいものです；；
＞ 考えたみましたが、かなり骨格を変えなければならないかもです。
作れたらアップしますが、ちょっと時間が掛かりそう。
本当ですか！？全然時間はいくらでも待てます！自分でも色々挑戦してみます！
（SoulMan）様
お忙しいのにありがとうございます＞＜
ちゃんと動いています！6月のシフトで実行してみたのですが、見たところ連続して同じ場所は選ばれていませんでした！！しかし下記のようにそれぞれABCDEFに差が出てしまっている状態です。。
合計 A B C D E F
21 5 5 4 2 2 3
16 2 4 0 5 3 2
11 1 3 4 1 1 1
20 3 3 4 7 1 2
16 5 1 1 3 4 2
22 4 2 4 5 3 4
22 3 3 4 4 5 3
19 4 6 2 0 3 4
17 1 2 4 1 3 6
16 2 1 3 2 5 3
本当に何度もありがとうございます(´;ω;｀)
（ゆゆ） 2021/06/15(火) 16:25
こんばんは！ なかなか苦戦してますね(^^; いつぞやの数独を思い出しましたよ。。。 ところでちょっと条件を追加してみました。。。
1.隣が自分と同じでないこと に加えて 2.自分より5つ前までに自分がいないこと
さらに、、気になっていたんですけど、、トピ主さんの言う偏りは、、 どうやって集計されているのですか？？？
ひょっとしてトピ主さんは私なんかよりずっと出来る人だったりしませんか？？？ なんとなくわかるんですよね、、回答者みたいなことを長くやってると。。。。 それはさておき、、
3.最初に与える配列を使用頻度の少ない順に渡します。 こうすることで使われていないものから使われる可能性が高まりますから、、 いくらかは改善されるでしょう。。多分(^^;
でも、条件をきつくした分成功しない時があります。 脱出弾を追加していますので必要に応じて 休 を調整してください。
一応、、このくらいの休みならなんとか動いています。。。
では、、では、、、
なお、何分にもずぶのど素人が片手間で書いたコードですのでお気に召さない箇所等は適当にアレンジしていただけますと幸甚です。
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J]
[1] | |9月26日|9月27日|9月28日|9月29日|9月30日|10月1日|10月2日|10月3日|10月4日
[2] |りんご|休 | | | |休 | |休 | |
[3] |みかん| | |休 |休 |休 |休 | |休 |休
[4] |いちご|休 |休 |休 |休 | |休 | |休 |
[5] |すいか| |休 | |休 | | |休 | |休
[6] |めろん| | |休 | |休 | |休 | |
[7] |れもん| |休 | |休 | |休 |休 | |休
[8] |バナナ|休 |休 |休 | |休 | | | |
[9] |キウィ| |休 |休 | | |休 | |休 |休
[10]|ブドウ| |休 |休 |休 | |休 | | |
[11]|チェリ| | | |休 | | |休 | |
[12]| | | | | | | | | |
[13]| |9月26日|9月27日|9月28日|9月29日|9月30日|10月1日|10月2日|10月3日|10月4日
[14]|りんご|休 |C |A |F |休 |D |休 |(休) |B
[15]|みかん|A |D |休 |休 |休 |休 |B |休 |休
[16]|いちご|休 |休 |休 |休 |B |休 |D |休 |F
[17]|すいか|B |休 |D |休 |C |B |休 |A |休
[18]|めろん|(休) |F |休 |D |休 |C |休 |F |A
[19]|れもん|D |休 |F |休 |A |休 |休 |D |休
[20]|バナナ|休 |休 |休 |C |休 |A |F |E |C
[21]|キウィ|E |休 |休 |A |D |休 |C |休 |休
[22]|ブドウ|C |休 |休 |休 |F |休 |A |B |E
[23]|チェリ|F |A |C |休 |E |F |休 |C |D
（SoulMan） 2021/06/15(火) 21:07
イミディエイトウィンドウに書き出してみました。 出現回数は、11146〜11153 現時点では少し B が多いですね。(^^; でもこれは途中経過なのでさらに実行すれば、、まだ、、逆転可能です。。
A 11150 B 11153 C 11146 D 11151 E 11149 F 11148 （SoulMan） 2021/06/15(火) 22:43
皆さんの回答を拝見させていただいております。 ちょっとExcelからはずれてしまうのですが、余談失礼します。
この種の問題は、0-1整数最適化問題に分類され、「ナーススケジューリング問題」と呼ばれているそうです。
職員i が、j日において、シフトkを担当するとき、 x[i,j,k] に 1を立て、そうでないときは0 とするような、値がBinary(0か1か）の3次元配列を考えます。
これに一定の制約条件、例えば、前日と同一のシフトは回避するといった制約
x[i,j-1,k] +x[i,j,k] <= 1
とか、
x[i,j,k] のjについての合計に対して、下限、上限を与える、
といった制約条件を付加して、ある種の最大最小値問題に帰着できます。
残念ながら、Excelのソルバーは「200個の変数セルと100件の制約条件」という制約があるので、対応できませんが、Excel以外でもソルバーはありますので、それにトライしてみるとよいかもしれません。
私がトライしたところ、以下のような結果が得られました。 最初の質問での休日状況をそのまま使いました。 （変数は2640個、制約条件数は約5000でした）
A B C D E F
21 4 4 4 3 3 3
16 2 3 3 3 3 2
11 1 2 2 2 2 2
20 3 4 3 3 3 4
16 3 2 2 3 3 3
22 4 4 3 4 3 4
22 3 3 4 4 4 4
19 3 3 3 3 4 3
17 3 3 3 3 2 3
13 3 2 2 2 2 2
（連続して同一のシフトにならないようにしています。）
ご参考まで。 （γ） 2021/06/16(水) 06:20
こんな結果です。 F C F E 休 B E A D C 休 休 D A 休 B D E 休 C B 休 A 休 F 休 B C A 休 B 休 休 休 F C 休 E 休 A 休 D E 休 C 休 B 休 D E 休 D 休 A 休 B C 休 F 休 D 休 休 休 A 休 休 C 休 D C 休 休 休 B 休 F 休 B 休 休 休 休 E 休 F 休 休 E 休 休 A D F B 休 A 休 F 休 D C B E 休 E 休 D F B E 休 F 休 休 C A 休 B C 休 D E A C A D 休 B 休 休 休 休 B 休 F 休 F 休 休 休 休 C 休 E D E F 休 A 休 E B 休 休 D F 休 A E F A F C 休 D E B C A 休 F B C D 休 D A 休 B E F 休 B D 休 C F C 休 B F A F E 休 A 休 E D C E D 休 C A 休 B D 休 休 B C 休 E F 休 B E 休 A E C 休 D A 休 A 休 休 F C 休 D B 休 F D 休 E C 休 A D 休 休 B D 休 B E 休 休 D F C 休 C 休 休 A B 休 F A 休 休 E 休 F 休 休 休 休 休 休 休 休 休 F 休 B 休 休 A 休 C 休 A F D A E B 休 E 休 休 C D
（γ） 2021/06/16(水) 06:26
これだけ休みの人が多いと、担当日数については平等とかはそんなに関係ない気もします。 出社した人は全員に割り振るしかないと言ってもよさそう。 もしかして、7人以上は出社させないようにしているんですかね。余計な詮索ですけども。
理詰めで解けるかと思っていましたが、無理の様でしたので、 乱数を使ったシミュレーション方式にするしかなかったです。
最多で20回トライしますが、途中でよさそうな結果が出ればそれで終了します。 (本来は、20回中一番いい結果を採用すべきですが、それはちょっと面倒なので止めました）
Type staff
Name As Variant
ScheD As Range
CurrV() As Variant '当日割り当て当番の記録
CurrA As Range '今月担当した当番の種類と数
AccmT As Range ' 累計当番数
AccmAddedDayOff As Long '休暇加算後の累計当番数
preJob As String '休をスルーした前回ジョブ
End Type
Const numOfJobs As Long = 6 'ABCDEF Const numOfStaffs As Long = 10 '人数
Private 社員(1 To numOfStaffs) As staff Private 連番Ary()
Sub JobAssign()
Dim ws当番 As Worksheet
Dim 当日割当管理板() As Boolean '当日割当てた当番を記録
Dim 当番名Ary
Dim idx
Dim JobIdx As Long '当番名のIndex
Dim DateCol As Long
Dim Fewest As Long '最優先キー
Dim sortKey As Long '当日回数<累計割当＜idx
Dim unAssigned As Long '未割当数
Dim App As Application
Dim trial As Long
ClearResult
Set App = Application
連番Ary = Evaluate("row(A1:A" & numOfJobs & ")")
Set ws当番 = Sheets("当番表")
App.ScreenUpdating = False
Rem 基本データを格納
With ws当番
当番名Ary = .Range("AI1:AP1").Value '当番名配列
For idx = 1 To numOfStaffs
社員(idx).Name = .Cells(idx + 1, "A").Value
Set 社員(idx).ScheD = .Cells(idx + 1, "B").Resize(1, 31)
Set 社員(idx).CurrA = .Cells(idx + 1, "AI").Resize(1, numOfJobs)
Set 社員(idx).AccmT = .Cells(idx + 1, "AQ")
Next idx
'表の集計エリアのタイトルを書き込む
.Range("AH1").Resize(1, 10).Value = [{"合計","A","B","C","D","E","F","予備","調整","調整後"}]
'集計用の数式を埋め込む
.Range("AH2:AO10").ClearContents
.Range("AH2").Resize(numOfStaffs, 1).FormulaR1C1Local = "=SUM(RC[1]:RC[7])"
.Range("AQ2").Resize(numOfStaffs, 1).FormulaR1C1Local = "=SUM(RC[-9],RC[-1])"
.Range("AI2").Resize(numOfStaffs, 7).FormulaR1C1Local = _
"=IF(RC1="""","""",IF(LEFT(R1C,2)=""予備"","""",COUNTIF(RC2:RC33,""*""&R1C&""*"")))"
End With
Rem 割当開始
For trial = 1 To 20
For DateCol = 1 To 31 '31迄 日付順に決定する
ReDim 当日割当管理板(1 To numOfJobs)
'当日、全社員が休みでないか、または日付データが正しいか、事前確認
If App.CountIf(ws当番.Cells(2, DateCol + 1).Resize(numOfStaffs), "*休*") < numOfStaffs And IsDate(ws当番.Cells(1, DateCol + 1)) Then
'各社員が当日に割当てられた当番の記憶をクリア
For idx = 1 To numOfStaffs
ReDim 社員(idx).CurrV(0 To numOfJobs)
Next idx
'---------------------------------
'最少当番割当者を決定する. 順位；当日割当数＜累計割当数
unAssigned = numOfJobs '未割当数を初期化
Do While unAssigned > 0
Fewest = 99999999 '仮置き
For idx = 1 To numOfStaffs
With 社員(idx)
If .ScheD(1, DateCol).Value = "" Or .ScheD(1, DateCol).HasFormula Then
'予定休日を当番割当数に加算する(休みも当番の内?）
.AccmAddedDayOff = .AccmT(1, 1) + App.CountIf(.ScheD(1, 0).Resize(1, DateCol), "休")
sortKey = .CurrV(0) * 100000 + .AccmAddedDayOff * 100 + idx
Fewest = App.Min(sortKey, Fewest)
End If
End With
Next idx
idx = Fewest Mod 100 '割当てるべきスタッフのIndexをセット
JobIdx = getJob(社員(idx), 連番Ary, 当日割当管理板) '割り当てる当番名Indexを取得する
'割り当てる当番名を数式の形で出力する
社員(idx).ScheD(1, DateCol).Formula = "=""" & 社員(idx).ScheD(1, DateCol) & 当番名Ary(1, JobIdx) & """"
'決定後の処理
社員(idx).CurrV(0) = 社員(idx).CurrV(0) + 1 '同社員の当日担当数をインクリメント
当日割当管理板(JobIdx) = True '決定フラグで埋めて、割当状況を更新
unAssigned = unAssigned - 1 '未割当て残数をディクリメント
Loop
End If
'当日余った人は、強制的に休みにする（表示文字は「(休)」として、手入力の休みとは区別する。
If IsDate(ws当番.Cells(1, DateCol + 1)) Then
On Error Resume Next
ws当番.Cells(2, DateCol + 1).Resize(numOfStaffs).SpecialCells(xlCellTypeBlanks).Value = "=""(休)"""
On Error GoTo 0
End If
'rem 連続回避処置
If DateCol >= 2 Then
連続回避調整 DateCol
End If
'当日確定ジョブデータを前回担当ジョブに格納して、次の日の処理に備える。
For idx = 1 To numOfStaffs
With 社員(idx)
If Not .ScheD(1, DateCol) Like "*休*" Then
.preJob = .ScheD(1, DateCol)
End If
End With
Next
Next DateCol
'出来ばえチェック
If doItOver = False Then
Exit Sub
Else
ClearResult
End If
Next trial
App.ScreenUpdating = True
End Sub
Private Function getJob(ByRef targetStaff As staff, ByRef 連番Ary, ByRef 当日割当管理板)
Dim JobsInOrder, NN As Long, RndAry
'担当過少当番順
ReDim JobsAssignedSofar(1 To UBound(連番Ary))
RndAry = get連番rnd
For NN = 1 To UBound(連番Ary)
JobsAssignedSofar(NN) = targetStaff.CurrA(1, NN) * 10000 + RndAry(NN, 1) * 100 + NN
Next NN
JobsInOrder = Application.Small(JobsAssignedSofar, 連番Ary)
For NN = 1 To UBound(連番Ary)
getJob = JobsInOrder(NN, 1) Mod 100
If 当日割当管理板(getJob) = False Then
Exit Function
End If
Next
End Function
Sub ClearResult() '手入力の休み以外を空白に戻す(振り出しの戻したい時に実行する)
On Error Resume Next
Range("B2:AF12").SpecialCells(xlCellTypeFormulas, 23).Clear
On Error GoTo 0
Range("B2").Select
End Sub
Function AvailableJobs(idx, DateCol As Long) '割当可能なジョブ
Dim leng As Long, k As Long
AvailableJobs = "ABCDEF"
With 社員(idx)
leng = Len(.preJob)
For k = 1 To leng
AvailableJobs = Replace(AvailableJobs, Mid(.preJob, k, 1), "")
Next k
End With
End Function
Sub 連続回避調整(DateCol As Long)
Dim idx
Dim nowAvJobs
Dim OtherAvJobs
Dim k, m
Dim exFlag
Dim p
Dim temp1, temp2
Dim wdReplace1, wdReplace2
For idx = 1 To numOfStaffs
With 社員(idx)
If Not .ScheD(1, DateCol) Like "*休*" Then
nowAvJobs = AvailableJobs(idx, DateCol)
For k = 1 To Len(.ScheD(1, DateCol))
exFlag = False
If InStr(nowAvJobs, Mid(.ScheD(1, DateCol), k, 1)) = 0 Then '不可の場合の処置
'取替えくれる人を探す
For m = 1 To numOfStaffs
exFlag = False
If m <> idx Then
If Not 社員(m).ScheD(1, DateCol) Like "*休*" Then
OtherAvJobs = AvailableJobs(m, DateCol)
If InStr(OtherAvJobs, Mid(.ScheD(1, DateCol), k, 1)) Then
For p = 1 To Len(社員(m).ScheD(1, DateCol))
If InStr(nowAvJobs, Mid(社員(m).ScheD(1, DateCol), p, 1)) Then '取替え
'自分idx-k と 相手m-p との交換
temp1 = 社員(idx).ScheD(1, DateCol).Value
wdReplace1 = Mid(temp1, k, 1)
temp2 = 社員(m).ScheD(1, DateCol).Value
wdReplace2 = Mid(temp2, p, 1)
Mid(temp1, k, 1) = wdReplace2
Mid(temp2, p, 1) = wdReplace1
社員(idx).ScheD(1, DateCol).FormulaLocal = "=""" & temp1 & """"
社員(m).ScheD(1, DateCol).FormulaLocal = "=""" & temp2 & """"
exFlag = True
Exit For
End If
Next p
End If
End If
End If
If exFlag Then
Exit For
End If
Next m
If exFlag Then
Exit For
End If
End If
Next k
End If
End With
Next idx
End Sub
Function get連番rnd()
Dim i, temp(1 To numOfJobs)
For i = 1 To 6
temp(i) = Rnd()
Next
With Application
get連番rnd = .Match(.Small(temp, 連番Ary), temp, 0)
End With
End Function
Function doItOver() As Boolean
Dim cel As Range, RW As Range, Avrg
For Each RW In Range("AI2:AN11").Rows
Avrg = Application.Average(RW)
For Each cel In RW.Cells
If Application.Round(Abs(cel - Avrg), 0) >= 2 Then
doItOver = True
Exit For
End If
Next
Next RW
End Function
（半平太） 2021/06/16(水) 15:00
既にVBAを使った回答が二つ提示されていますので、あえてこちらを使う必要も ないと思いますので気楽に書きます。
Juliaというオープンソース言語を使いました。（https://julialang.org/) JuMPという数理最適化パッケージを使い、ソルバーはGLPKを使用しました。
（Pythonにも最適化パーケージはありますので、そちらを調べたほうがよいかも。 Excelの質問掲示板なので顰蹙を買うかもしれませんが、 条件設定等で参考になる方もいらっしゃるかと思い、あえてメモします。）
# http://www.excel.studio-kazu.jp/kw/20210614183239.html using CSV using DataFrames using JuMP using GLPK
function test()
# 休日データの読み込み
holiday = CSV.File("data.csv",header=true) |> DataFrame |> Matrix ;
holiday = holiday[:,2:end] #休日:1 非休日:0
model = Model();
set_optimizer(model, GLPK.Optimizer);
@variable(model, x[1:10,1:30,1:7], Bin)
@variable(model, y[1:30,1:6], Int)
@variable(model, z[1:30,1:6], Int)
# 制約条件
@constraint(model, y .>= 0)
@constraint(model, z .>= 0)
# 休日設定
for i = 1:10,j = 1:30
holiday[i,j] == 1 && @constraint(model,x[i,j,7] == 1)
end
for i = 1:10 ,j = 1:30
holiday[i,j] == 0 && @constraint(model, sum(x[i,j,1:6]) == 1 ) # 選べるタスクは1つだけ
end
for j = 1:30 ,k = 1:6
@constraint(model, sum(x[:,j,k]) >= 1 - y[j,k] ) # タスク毎の選択回数下限
end
for j = 1:30 ,k = 1:6
@constraint(model, sum(x[:,j,k]) <= 1 + z[j,k] ) # タスク毎の選択回数上限
end
for i = 1:10, j = 2:30 ,k = 1:6
@constraint(model, x[i,j-1,k] + x[i,j,k] <= 1 ) # 2日連続同一タスクは回避
end
# 個人別にみた月合計タスク数の上限と下限
for i = 1:10, k = 1:6
kaisu = (30 - sum(holiday[i,:])) ÷6
@constraint(model, kaisu <= sum(x[i,:,k]) <= kaisu + 1)
end
# 最適化の目的変数
@objective(model, Min, sum(y + z) )
# 最適化の実行
optimize!(model)
@show objective_value(model) # 目標値の結果
# 結果の取り出し
kekka = zeros(Int32,10,30,7)
for i =1:10,j=1:30,k=1:7
kekka[i,j,k] = Int32(value(x[i,j,k]))
end
@show kekka
# データの加工部分は省略
end
@time test()
# ------------- コード終了 ---------------------
それなりの結果を出力はします。 ただ、目標値が0にかなり近いe-17 のような整数ではないものになっている あたり、ホンマかいな、という気にもなっています。 まだ研究の余地が残っている感じですが、とりあえず回答して責を果たしておきます。 （γ） 2021/06/16(水) 21:06
こんばんは！ 学校らしくなってきましたね。 そうだったんですね。。そんな有名な問題だったんですね。。。 わたしゃってきりゲームか何かかなと思っていました。。。。 ということで、、皆さんの素晴らしい回答のあとで出しずらくなっちゃいましたが、、参考出展させてください。
トピ主さんは動かなかった環境ですが、、後々、このトピを参考にされる方もいっらしゃるでしょうから 乱数は、メルセンヌツイスタ にして(あまり関係ないただの趣味趣向(^^;)
出現回数を「出現履歴シート」で管理するようにしてみました。。 こうすることで、、実行中だけでなく一度閉じて開いても出現履歴を継承出来るかなと。。。 また、途中で出現履歴に介入することもできますから、、特定の人の回数を少なくするとその人が優先的に出現する？気がします(^^; 出現履歴シートからメンバーを作ることも勿論可能なのですが、、簡単に変更出来ても困ると思いますので、、 最初だけ、、出現履歴シートA1から下に A B C D E F と入力してください。。
で、何回繰り返すか？ですけど、、どこかのトピで使った「学習する」パターンにしてみました。 こうすることで過去の最も良かったパターンになるまで繰り返します。 実行するたびに学習して賢くなるイメージです。 なので最初は、、動いていても回数を重ねるにつれて失敗することが増えてきます。。。 その場合は、、その辺であきらめていただくか(おぉぉいい！！)。。。休日の配置を変えてみてください。。 そうするとまた新しくチャレンジしていきます。。。
でも、この評価が微妙です。(^^; 偏りがあります。。。が、、長期にみると差がないような？？？ まぁ、、既に解決されてるっぽいので、、、自己満足の世界？？？(実は満足していない(笑)
十分な動作確認が出来ていませんので、、駄目な時があったらごめんなさいです。。。 では、、では、、、
Option Explicit ' ＶＢＡによるメルセンヌツイスタ ' システムを起動してからの時間をミリ秒単位で返す ' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx 'Private Declare Function GetTickCount Lib "kernel32" () As Long Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As Long ' メルセンヌツイスタのパラメータ(ダイナミッククリエーターの結果) Private Const MTN = 644, MTM = 322, MTA = 12, MTB = 7, MTC = 15, MTD = 18 Private Const MXA = &H70C20000, UMK = &H78000000, LMK = &H7FFFFFF Private Const MKB = &H73736B80, MKC = &H6ED28000 ' 補助的な定数の宣言 Private Const MTL = MTN - MTM, MTK = MTN - 1, MTJ = MTL - 1, MTP = MTN - 2 Private Const PWA = 2 ^ MTA, PWB = 2 ^ MTB, PWC = 2 ^ MTC, PWD = 2 ^ MTD Private Const KB = MKB \ PWB, KC = MKC \ PWC Private Const P32 = 2# ^ 32, P31 = 2 ^ 31, P22 = 2# ^ 22, P9 = 2 ^ 9 Private Const M53 = 2# ^ -53, M32 = 2# ^ -32, M30 = 2# ^ -30 ' 乱数の状態 Private mt(0 To MTK), mti As Long ' 初期化の補助関数 Private Function Ri(ByRef r As Double, ByVal i As Long) As Long Dim s As Variant Dim shft As Double Dim a As Long If r >= P31 Then a = r - P32 Else a = r a = a Xor Int(r * M30) If a < 0 Then r = a + P32 Else r = a s = 1812433253 * CDec(r) + i: r = s - CDec(Int(s * M32)) * P32 If r >= P31 Then Ri = r - P31 Else Ri = r End Function ' s を種にして乱数を初期化する Public Sub InitMt(ByVal s As Long) Dim r As Double mt(0) = s And &H7FFFFFFF If s < 0 Then r = P32 + s Else r = s For mti = 1 To MTK: mt(mti) = Ri(r, mti): Next mti mti = MTN End Sub ' 31 ビットの整数乱数 Public Function NextMt() As Long Dim y, k As Long If mti = 0 Then InitMt (1) If mti = MTN Then mti = 0 For k = 0 To MTJ y = (mt(k) And UMK) Or (mt(k + 1) And LMK) mt(k) = mt(k + MTM) Xor (y \ 2) Xor (-(y And 1) And MXA) Next k For k = MTL To MTP y = (mt(k) And UMK) Or (mt(k + 1) And LMK) mt(k) = mt(k - MTL) Xor (y \ 2) Xor (-(y And 1) And MXA) Next k y = (mt(MTK) And UMK) Or (mt(0) And LMK) mt(MTK) = mt(MTM - 1) Xor (y \ 2) Xor (-(y And 1) And MXA) End If y = mt(mti): mti = mti + 1 y = y Xor (y \ PWA): y = y Xor ((y And KB) * PWB) y = y Xor ((y And KC) * PWC): y = y Xor (y \ PWD): NextMt = y End Function ' 0 以上 1 未満の乱数を返す Public Function NextUnifMt() As Double Dim x As Long x = NextMt \ P9: NextUnifMt = (NextMt * P22 + x) * M53 End Function ' 時間を種にして乱数を初期化する Public Sub RandomizeMt() InitMt (GetTickCount64()) End Sub Sub NurseScheduling_SoulMan() Dim MyDic As Object Dim v As Variant Dim x As Variant Dim 出現履歴 As Variant Dim xy As Variant Dim y As Variant Dim z As Variant Dim q() As Variant Dim Di As Variant Dim 評価 As Variant Dim 書出調整 As Variant Dim 組込調整 As Variant Dim x1 As Variant Dim x2() As Variant Dim MyFSh As Worksheet Dim n As Long Dim i As Long Dim j As Long Dim k As Long Dim r As Long Dim xi As Long Dim ixi As Long Dim n1 As Long Dim 脱出弾 As Long Static 休日配置 As Variant Static 出現差異 As Long Static 通算 As Long Static 回数 As Long Static MyAnser As Long Dim MyFlg As Boolean Dim 判定 As Boolean Const MyWs As String = "シフト表" Const MySh As String = "出現履歴" Const MySk As String = "結果保存" If Not Evaluate("=ISREF(" & MyWs & "!A1)") Then Sheets.Add.Name = MyWs If Not Evaluate("=ISREF(" & MySh & "!A1)") Then Sheets.Add.Name = MySh If Not Evaluate("=ISREF(" & MySk & "!A1)") Then Sheets.Add.Name = MySk Set MyFSh = ActiveSheet 出現履歴 = Sheets(MySh).Range("A1").CurrentRegion.Resize(, 2).Value x = Array("A", "B", "C", "D", "E", "F") Set MyDic = CreateObject("Scripting.Dictionary") For i = LBound(x) To UBound(x) MyDic(x(i)) = Empty Next xy = Application.Transpose(Application.Transpose(MyDic.Keys)) For Each Di In MyDic.Keys If IsError(Application.Match(Di, Application.Index(出現履歴, 0, 1), 0)) Then MsgBox "登録されていないデータがあります。。。。" Exit Sub End If Next For i = LBound(出現履歴, 1) To UBound(出現履歴, 1) If Not MyDic.Exists(出現履歴(i, 1)) Then MsgBox "登録されていないデータがあります。。。。" Exit Sub End If Next With Sheets(MySh) q = .Range("A1").CurrentRegion.Resize(, 2).Value QuickSort q, 2, LBound(q, 1), UBound(q, 1) .Range("I1").Resize(UBound(q, 1), UBound(q, 2)).Value = q .Range("I:J").EntireColumn.AutoFit End With For i = LBound(x) To UBound(x) x(i) = q(i + 1, 1) MyDic(x(i)) = q(i + 1, 2) Next With Sheets(MyWs) With .Range("A1").CurrentRegion v = .Resize(11, .Columns.Count + 1).Value End With ReDim 書出調整(LBound(v, 1) To UBound(v, 1), LBound(v, 2) To UBound(v, 2)) .Range("A13").Offset(UBound(v, 1)).Resize(UBound(書出調整, 1), UBound(書出調整, 2)).Value = 書出調整 End With If IsArray(休日配置) Then For i = LBound(v, 1) To UBound(v, 1) For j = LBound(v, 2) To UBound(v, 2) If 休日配置(i, j) <> v(i, j) Then 判定 = True Exit For End If If 判定 Then Exit For Next If 判定 Then Exit For Next If 判定 Then 休日配置 = v 出現差異 = 10000 MyAnser = 0 MsgBox "休日配置が変更されました。。。" & vbCrLf & _ "新しいパターンの学習を開始します。。。。" End If Else 休日配置 = v 出現差異 = 10000 MyAnser = 0 End If Do RandomizeMt For j = LBound(v, 2) + 1 To UBound(v, 2) - 1 y = Application.Transpose(Application.Index(v, 0, j)) ReDim z(UBound(v, 1) - 2) xi = 0 k = 0 For i = LBound(y) To UBound(y) - 1 xi = xi + 1 If y(xi + 1) = "休" Then z(xi - 1) = "休" Else If k <= UBound(x) Then z(xi - 1) = x(k) k = k + 1 End If End If Next For i = LBound(z) To UBound(z) If z(i) = "" Then z(i) = "(休)" Next Do MyFScs z k = 0 MyFlg = False For i = LBound(v, 1) + 1 To UBound(v, 1) If v(i, j) = "休" Then v(i, j) = "休" Else If z(k) <> "休" Then v(i, j) = z(k) k = k + 1 Else k = k + 1 i = i - 1 End If End If Next If j > 2 Then UniqueCheck v, j, x, "休", "(休)", MyFlg 脱出弾 = 脱出弾 + 1 If 脱出弾 > 10000 Then Sheets(MySh).Range("N1").Value = "失敗" Sheets(MyWs).Range("A13").Resize(UBound(休日配置, 1), UBound(休日配置, 2)).Value = 休日配置 MsgBox "規程数に達しました。。。" & vbCrLf & _ "休日配置を変更 または、" & vbCrLf & _ "もう一度チャレンジしてください。。。。" Exit Sub End If Loop Until MyFlg = False Next ReDim 評価(UBound(x)) For i = LBound(v, 1) To UBound(v, 1) For j = LBound(x) To UBound(x) n = UBound(Filter(Application.Index(v, i, 0), x(j), True)) + 1 評価(j) = 評価(j) + n Next Next n = Application.Max(評価) - Application.Min(評価) If 出現差異 > n Then 出現差異 = n MsgBox "出現差異が更新されました。。。" & vbCrLf & _ "現在の出現差異は、 " & 出現差異 & " です。。。。" End If Loop Until n = 出現差異 For i = LBound(v, 1) + 1 To UBound(v, 1) For j = LBound(v, 2) + 1 To UBound(v, 2) If MyDic.Exists(v(i, j)) Then MyDic(v(i, j)) = MyDic(v(i, j)) + 1 Next Next If MyAnser = 0 Then If vbYes = MsgBox("配置されないメンバーがいたら表示しますか？", vbYesNo) Then MyAnser = 1 Else If vbYes = MsgBox("配置されないメンバーがいたら組込ますか？", vbYesNo) Then MyAnser = 2 End If If MyAnser = 0 Then MyAnser = 3 End If For j = LBound(v, 2) + 1 To UBound(v, 2) - 1 x1 = Join(x, ",") n1 = 0 n = UBound(Filter(Application.Transpose(Application.Index(v, 0, j)), "休", True)) + 1 If n > (UBound(v, 1) - 1) - (UBound(x) + 1) Then For i = LBound(v, 1) + 1 To UBound(v, 1) x1 = Replace(x1, v(i, j), "") Next x1 = Split(x1, ",") Select Case MyAnser Case 1 For i = LBound(x1) To UBound(x1) If x1(i) <> "" Then n1 = n1 + 1 書出調整(n1, j) = x1(i) If 書出調整(n1, 1) = "" Then 書出調整(n1, 1) = "要調整" & n1 If MyDic.Exists(x1(i)) Then MyDic(x1(i)) = MyDic(x1(i)) + 1 End If Next Case 2 For i = LBound(x1) To UBound(x1) If x1(i) <> "" Then ReDim Preserve x2(n1) x2(n1) = x1(i) n1 = n1 + 1 End If Next ReDim 組込調整(LBound(v, 1) + 1 To UBound(v, 1), 1 To 2) n1 = 0 For ixi = LBound(x2) To UBound(x2) MyFlg = False For i = LBound(v, 1) + 1 To UBound(v, 1) n = UBound(Filter(Application.Index(v, i, 0), x2(ixi), True)) + 1 組込調整(i, 1) = n 組込調整(i, 2) = i Next QuickSort 組込調整, 1, LBound(組込調整, 1), UBound(組込調整, 1) For xi = LBound(組込調整, 1) To UBound(組込調整, 1) If (v(組込調整(xi, 2), j) <> "休") * (v(組込調整(xi, 2), j) <> "(休)") Then If (v(組込調整(xi, 2), j - 1) <> x2(ixi)) * (v(組込調整(xi, 2), j + 1) <> x2(ixi)) Then If Len(v(組込調整(xi, 2), j)) = 1 Then v(組込調整(xi, 2), j) = v(組込調整(xi, 2), j) & x2(ixi) If MyDic.Exists(x2(ixi)) Then MyDic(x2(ixi)) = MyDic(x2(ixi)) + 1 MyFlg = True Exit For End If End If End If Next If MyFlg = False Then n1 = n1 + 1 書出調整(n1, j) = x2(ixi) If 書出調整(n1, 1) = "" Then 書出調整(n1, 1) = "要調整" & n1 If MyDic.Exists(x2(ixi)) Then MyDic(x2(ixi)) = MyDic(x2(ixi)) + 1 End If Next Case 3 End Select End If Next Application.ScreenUpdating = False With Sheets(MySh) .Range("B1:B6,F1:F3,J1:J6,N1:N2").NumberFormat = "#,##0" .Range("E1").Value = "Max" .Range("E2").Value = "Min" .Range("E3").Value = "Diff" .Range("M1").Value = "Challenge_Num" .Range("N1").Value = 脱出弾 .Range("M2").Value = "Challenge_Ave" .Range("A1").Resize(MyDic.Count).Value = Application.Transpose(MyDic.Keys) .Range("B1").Resize(MyDic.Count).Value = Application.Transpose(MyDic.Items) .Range("F1").Formula = "=MAX(B1:B6)" .Range("F2").Formula = "=MIN(B1:B6)" .Range("F3").Formula = "=F1-F2" 回数 = 回数 + 1 通算 = 通算 + 脱出弾 .Range("N2").Value = Int(通算 / 回数) .Range("A:N").EntireColumn.AutoFit End With With Sheets(MyWs) .Rows(12).Clear With .Range("A13") .Resize(UBound(v, 1), UBound(v, 2)).Value = v With .CurrentRegion .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=A13=""休""" .FormatConditions(1).Interior.Color = vbYellow End With .Offset(UBound(v, 1)).Resize(UBound(書出調整, 1), UBound(書出調整, 2)).Value = 書出調整 .CurrentRegion.Copy Destination:=Sheets(MySk).Range("A" & Rows.Count).End(xlUp).Offset(2) End With r = Sheets(MySk).Range("A" & Rows.Count).End(xlUp).Row r = Sheets(MySk).Range("A" & r).End(xlUp).Row Application.Goto Sheets(MySk).Range("A" & r).End(xlUp).Offset(1), True End With MyFSh.Activate Application.ScreenUpdating = True Set MyDic = Nothing Set MyFSh = Nothing If IsArray(書出調整) Then Erase 書出調整 If IsArray(組込調整) Then Erase 組込調整 If IsArray(x2) Then Erase x2 Erase 出現履歴, xy, v, x, y, z, q, 評価 End Sub Private Sub UniqueCheck(ByVal v As Variant, ByVal j As Long, ByVal x As Variant, ByVal MyStrA As String, ByVal MyStrB As String, ByRef MyFlg As Boolean) Dim i As Long Dim xi As Long For i = LBound(v, 1) + 1 To UBound(v, 1) If (v(i, j) <> MyStrA) * (v(i, j) <> MyStrB) Then For xi = j - 1 To j - (UBound(x)) Step -1 If v(i, j) = v(i, xi) Then MyFlg = True Exit Sub End If If xi = 1 Then Exit For Next End If If MyFlg = True Then Exit Sub Next End Sub Private Sub MyFScs(ByRef x As Variant) Dim y As Variant Dim i As Long Dim j As Long Dim MyScs As Object Set MyScs = CreateObject("System.Collections.SortedList") ReDim y(LBound(x, 1) To UBound(x, 1)) For i = LBound(x, 1) To UBound(x, 1) MyScs(NextUnifMt()) = i Next For i = 0 To MyScs.Count - 1 y(i) = x(MyScs.Getbyindex(i)) Next x = y Set MyScs = Nothing Erase y End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As Variant MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub まだ他にも不具合があるかもしれませんが、一応、見直しました。2021/6/17 23：13 まっ、、誠に申し訳ございません。。ごみが残ってました。m(__)m そっかぁ、、ナースかぁ、、いいね v(=∩_∩=)v ←なににやけとんねん。。。スンマセン 2021/06/18 07:15 （SoulMan） 2021/06/16(水) 23:33
（ゆゆ） 2021/06/17(木) 01:52
こうした手法に興味をお持ちの方に、若干の補足をしておきます。
この例では、各タスクには多くとも1人を割当ることになりますが、 通常は、j日のタスクkに割り当てるべき人数を req[j,k]として指定し(requiredの積もり） 下記のような制約条件として使います。 | # タスク毎の選択回数下限 | for j = 1:d ,k = 1:w | @constraint(model, sum(x[:,j,k]) >= req[j,k] - y[j,k] ) | end | # タスク毎の選択回数上限 | for j = 1:d ,k = 1:w | @constraint(model, sum(x[:,j,k]) <= req[j,k] + z[j,k] ) | end ここで、 y[j,k] は、非負の整数で、組み合わせ上やむをえず割当できない人数 z[j,k] は、非負の整数で、組み合わせ上やむをえず割当すぎてしまう人数 を表し、この合計を最小にするように最適化するということですね。
ちなみに、質問者さんには、実際に試すのは気持ちだけにしておいたほうがいいです。 （成り行きでの話で本気にはしていませんが。） こうした数理最適化的な分野を勉強されたいという希望でもあれば別ですが、 使える環境を整えるだけでも相当な労力が必要ですから。 （γ） 2021/06/17(木) 10:30
こんばんは！
UniqueCheck を追加して条件を更に厳しくしてみました。 このコードを書き始めたときは「流石にそれは無理だろう」と少し条件を緩めていました。 どうなるのかなぁ、、と試してみましたところ、、現在の休日配置なら、なんとか許容範囲かなと、、、
これで同日に重ならないのは勿論のこと6日以内にも自分は出現しません。。。いや、、そのはずです。。自信なく小声・・・・(^^; ただ、条件を厳しくした為、結構止まります。。。結果は、こんな↓感じです。。。。 毎回、2000回前後チャレンジして出た結果です。。。まぁ、、Excelがやることですから。。。別にいいのですが、、、Excelも頑張っているなぁ、、と思いました。(^^;
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X] |[Y] |[Z] |[AA] |[AB] |[AC]
[13]| |6月16日|6月17日|6月18日|6月19日|6月20日|6月21日|6月22日|6月23日|6月24日|6月25日|6月26日|6月27日|6月28日|6月29日|6月30日|7月1日|7月2日|7月3日|7月4日|7月5日|7月6日|7月7日|7月8日|7月9日|7月10日|7月11日|7月12日|7月13日
[14]|あ1 |A |D |F |E |休 |B |C |A |D |E |F |休 |B |A |休 |D |E |F |休 |C |A |休 |E |休 |F |休 |B |C
[15]|あ2 |休 |休 |休 |休 |C |D |休 |F |休 |B |休 |E |D |休 |A |休 |C |休 |B |E |休 |D |休 |C |休 |B |A |休
[16]|あ3 |B |休 |休 |休 |A |休 |休 |C |休 |D |B |休 |休 |休 |C |休 |B |休 |F |休 |休 |休 |休 |A |休 |D |休 |休
[17]|あ4 |休 |A |C |B |F |休 |D |休 |E |休 |(休) |C |F |B |休 |E |休 |D |C |F |B |休 |A |休 |休 |F |C |休
[18]|あ5 |休 |C |A |D |B |E |F |休 |C |休 |休 |休 |休 |E |休 |A |休 |C |休 |休 |休 |休 |D |休 |E |C |F |A
[19]|あ6 |休 |B |E |休 |休 |C |A |休 |B |F |E |D |A |C |休 |B |F |E |D |A |休 |B |C |F |D |休 |E |B
[20]|あ7 |D |F |休 |C |E |休 |B |D |A |休 |C |F |E |D |B |休 |A |休 |E |D |F |C |B |休 |A |E |休 |D
[21]|あ8 |休 |E |B |休 |D |A |休 |E |F |休 |D |A |C |休 |E |F |休 |A |休 |休 |D |F |休 |E |B |休 |D |F
[22]|あ9 |E |休 |D |A |休 |休 |E |B |休 |C |A |休 |休 |F |D |C |休 |B |休 |休 |E |A |休 |B |C |休 |休 |E
[23]|あ10|休 |休 |休 |休 |休 |休 |休 |休 |休 |A |休 |B |休 |休 |F |休 |D |休 |A |B |C |E |F |D |休 |A |休 |休
それから出現履歴シートを使ってちょっこと解析してみました。
|[A]|[B] |[C]|[D]|[E] |[F] |[G]|[H]|[I]|[J] |[K]|[L]|[M] |[N]
[1]|A |35,142| | |Max |35,142| | |C |35,111| | |Challenge_Num|1,797
[2]|B |35,140| | |Min |35,140| | |E |35,111| | |Challenge_Ave|1,995
[3]|C |35,141| | |Diff| 2| | |A |35,112| | | |
[4]|D |35,142| | | | | | |D |35,112| | | |
[5]|E |35,141| | | | | | |F |35,113| | | |
[6]|F |35,142| | | | | | |B |35,113| | | |
35,000回以上出現して多い人と少ない人の差は、、2〜3 回 多分、、これ以上やっても結果は同じだと思います。
わちきの能力では、この辺が限界なのかもしれません。 これでナースさんが「私ばっかり、、」って喧嘩にならなければいいですね。(^^;
表題の「平等な当番表」に少しは近づけたかなと、、、 後は、、あくまでもサンプルですから実際の使用状況に合わせてアレンジしていただけると幸いです。。。 他にも回答がありますしね。。。
今回は、今回も？長々と更には度重なる修正、、誠に失礼致しました。。。まだ、あるかもしれませんが、、その時はお許しをm(__)m
では、、では、、、また、、、がありませんように。。。。v(=∩_∩=)v （SoulMan） 2021/06/18(金) 20:32
おはようございます。。すみません。まだ、ありました。m(__)m 休みの関係で配置されなかったメンバーの処置をしていませんでした。(というかぁ、念頭になかったです。。。）
配置されなかったメンバーをどうしようかと悩んだ結果、、調整欄を追加してそこに書き出すことにしました。
シフト表の中に組み込むことも考えましたが折角バランスが取れているのに それを崩しては意味がない様に思いますし、ある程度はオペレーターが介入して調整した方が汎用性もあがるでしょうから全体を見て最終調整してください。 で、この配置されなかったメンバーも出現履歴にカウントしますので出現履歴が意味のない様に思われます、、が、、、
出現履歴シートである特定のメンバーの出現履歴回数を極端に少なくするとそのメンバーが優先的に配置されて調整欄から外れます。 調整メンバーが偏って出力される場合はこの方法で調整してください。 なので運用方法として「ある特定のメンバーを優先的に配置したい時」などは、この方法で配置することが可能です。
あと失敗した時の出力結果を配置表に切り替えて初期化することにしました。 なので、、結果を比較する場合などは出力結果をその都度どこかにコピペするなどしておいた方が良いかもしれませんね。 細かい部分は色々あるでしょうが、今回はあくまでもサンプルなので万人向け仕様を想定しています。。。
今更ですが、、こういうのをコード化したいということは、、均等に配置するのが面倒なんでしょうね。。、 なので、最終的には、、オペレーターが介入して決定するので、、コード的にはその前段階まででいいのですね。。多分、、、 どうしてもオペレーターの思考が入りますから何回か実施して好みのパターンを採用しやすくしてあげればいいのかなと思いました。
それから Sheet1 → シフト表 にして シフト表 がなければ追加します。
変更点はそれぐらいでしょうか。。。そろそろ、、完成形に近づいて来たような気がするのですが、、、 まだ、、やっとたんかえぇ！！！って話ですよね。。。すっんません m(__)m （SoulMan） 2021/06/20(日) 10:24
こんばんは！ 休みの関係で配置されてされいないメンバーですが、書き出すか？組み込むか？を選択出来る様にしてみました。 で、どこに書き込むかですけど、配置されていないメンバーを見つけたら
10行の内で自分が一番少ない行 かつ 左と右に自分がいないこと が駄目な場合は次に少ない行 にしてみました。。。ほんまかいなですけど、、、 なので入れるなら「ここです。」みたいな。。。提案型です。 でも、、書き出した方が確実ですし、、条件を満たせない場合は、すべて組み込めない場合があります。。 なので最終的にはオペレーターが確認する必要があります。(^^; あくまでも均等に配置するためのお手伝い的な感じです。。。
で、最初と休日配置を変更したときだけ 配置されていないメンバーを書き出すか？ 配置されていないメンバーを組み込むか？ を聞いてきます。 どちらもNOの場合は、、何もしません。 2回目以降は、そのパターンを継承します。
つまり3パターンから選択できるようにしてみました。 ちょっとロジックをつぎ足しつぎ足しで改造したので全体が見渡せないのと検証が少なく不都合があるかもしれません。 まぁ、、万人向けを目標にした自己満足的な域になっていますので急ぎませんが明日からまた仕事なので出来るうちにと思いまして、、、
では、、では、、お騒がせしました。。。m(__)m （SoulMan） 2021/06/20(日) 21:59
こんばんは！ 昨日の配置されなかったメンバーを組込むロジックに誤りがありましたので訂正しました。m(__)m
10行の内で自分が一番少ない行 かつ 左と右に自分がいないこと に加えて 先客がいないこと が駄目な場合は次に少ない行
以上が全て駄目な場合は、調整欄に書き出されます。。。
先客は、自分を一文字としています。。。同じ行に全員組込んでも意味がないでしょうし、、 そのパターンはそんなに多くないでしょうからオペレーターが色々な状況を加味して判断した方が万人向けなのかなと思いました。
さらに、「結果保存シート」を追加して都度、配置結果を「結果保存シート」に保存する様にしました。 で、シフト表には書式もあるでしょうから、ここはあえて コピー にしてみました。 なのでたまには「結果保存シート」を覗いてみてください。。。結構、溜まってるかも？です。必要に応じて初期化してください。
均等に配置することを補助するということを目的にしましたから、「結果保存シート」の中から最終的なパターンを決定されればいいのかなと思いました。
それから、Msgboxが頻繁に出てくるのが煩わしく、本当はUserFormでインターフェイス的な操作にすれば更に汎用性が上がるかもしれませんね。 それは、、応用される方の宿題ということにしておきましょうね。そんな人がいればですけど(^^;
これでほぼほぼ完成したと思います。。。多分、、Final Answer になります様に！パンパン！！！ 長らくお騒がせ致しました。。。m(__)m
では、、では、、、 （SoulMan） 2021/06/21(月) 22:23
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.