『休みを考慮した当番表』（トド） 新たに当番表をつくることになりました。 シフト表をもとに、当番表を作成しています。 A B C D E F G H I J K 1 当番表 2023年12月 2 3 1 2 3 4 5 6 7 8 4 NO 担当者 出勤日数 水 木 金 土 日 月 火 水 5 1 佐藤 休 - - 6 2 鈴木 休 - - 7 3 高橋 - - 休 8 4 田中 休 - - 休 9 5 伊藤 - - 休 … … … … … … … … … … … … 32 29 中村 - - 33 30 小林 休 - - １．当番は５種類　A・B・C・D ２. 当番すべてそれぞれ４日くらい空けたい <例> A B C D E F G H I J K L M 4 No 担当者 出勤日数 水 木 金 土 日 月 火 水 木 金 5 1 佐藤 21 A 休 B - - A 6 2 鈴木 21 休 B - - A B 7 3 高橋 20 A - - B 休 A 8 4 田中 24 A 休 - - 休 A 9 5 伊藤 23 B A - - 休 B 10 6 山本 24 B - - B ３.当番の決定優先順位は　ＡＢ＞ＣＤ ４．土日祝日や休暇を考慮し、連続にならないようにする。 ５.担当者リストがあり、シフト表の担当者名は、 　担当者リストからリンクされている ６．シフト表の土日祝日は色が変わるようになっている。 　（祝日リストあり） ７.ＡＢＣＤあわせてなるべく同じ回数になるように平等に考慮する。 　調整する場合はＣＤで調整 マクロを頑張ってなんとか作ろうとしてみましたが、 いろいろ条件を考慮するのはエラーばかりで本当に難しいので、 教えていただけないでしょうか。 ＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞ ---- 追記 担当者リストについて <担当者リスト＞ A 　　　　B 　　C 1 担当者名 当番 　　イベント 2 佐藤 　　　　A,B,C 　　12/19 3 鈴木　　　 A,B,C,D 4 高橋 　　　　A,B,C,D 5 田中 　　　　A,B,D … … イベントがある人は（講習など席を外す人）は、 当番にあてていません。 よろしくお願いします。 （トド） 2023/11/21(火) 22:53:05 ---- ＞１．当番は５種類　A・B・C・D 4種類じゃないんですか。 ＞<担当者リスト＞ A,B,C,D は何を意味しているんですか。 （?） 2023/11/22(水) 08:38:33 ---- ?さん 当番は4種類でした。 担当者リストのABCDは 担当できる当番です。 例えば、佐藤さんはDの当番はせず、ＡとＢとＣだけ担当します。 （トド） 2023/11/22(水) 20:08:20 ---- ＞３.当番の決定優先順位は　ＡＢ＞ＣＤ 当番者は、1日に4人を選出するのですか？ それとも2名だけ選出するんですか？ <例>の表だと...A と B しか入ってないから 優先の順位とかぶって解り難いですが... （あみな） 2023/11/22(水) 20:45:48 ---- あみなさん はい。一日に４人選出します。 AとBの当番は、負担が大きいので、 先に配置させてしまうという意味合いでのせました。 わかりづらく申し訳ありません。 （トド） 2023/11/22(水) 21:08:00 ---- ＞担当者リストのABCDは ＞担当できる当番です。 ＞例えば、佐藤さんはDの当番はせず、ＡとＢとＣだけ担当します。 全員がリストに載っているんですか？ 普通は、やらない当番がある人だけ、書き出す様な気がするんですが・・面倒くさいので。 全種類やれる人が余り居ない職場なんですか？ テレワークとか、連休とかで、まとまって当番をやらない日が続く人は居ないのですか？ 居る場合、当番実績が必然的に少なくなるので、休み明けに集中的に当番に当たり勝ちになりますけども、 それはどう調整していますか？ (休んだのだからしょうがないと割り切る。出勤日数が少ない人は当番も少な目にして上げる） （半平太） 2023/11/22(水) 21:45:04 ---- 半平太さん 全員リストにのっています。 担当できる当番をリストにのせています。 スキルアップすると、責任のある当番が増えるので、 どれくらいのスキルがあるか全員が見えるようになっています。 連休をとられる方はいます。（テレワークはありません） シフト表に先に入力してもらっているので、 例えば中旬に連休をとられる方がいれば、 前半と後半に均等に配置されるようにしていますが、 AとBができる人に関しては、 負担が大きいため、立て続けに当番があてられてしまうのは 避けたいです。 当番Aと当番Bの間も一日はおきたいです。 仮にAやBの当番が少なくなってしまっても、 CやDの当番を増やし調整しています。 CやDは連続して当番になってしまっても ＯＫです。 全員の当番の平均が同じになるようにしています。 ＡとＢは連携して行う仕事なので、 毎回同じ方との組み合わせにならないように、 できる限り配慮しています。 （トド） 2023/11/22(水) 22:20:46 ---- 担当者リストは スキルがみえるようになっていれば フォームは特別決まりはありません。 例えば A B C D E F 1 担当者 当番A 当番B 当番C 当番D イベント 2 佐藤 〇 〇 〇 12/19 3 鈴木 〇 〇 〇 〇 4 高橋 〇 〇 〇 5 田中 〇 〇 〇 … … … … … … … 25 横山 〇 上記のような形に変えてもいいですし、 むずかしくない方法があればいいのですが…。 （トド） 2023/11/22(水) 22:33:19 ---- ＞当番Aと当番Bの間も一日はおきたいです。 20日ｘ4当番÷30人　→　2.7回/人 月に3回位ですよね。そんな事を心配する必要は無い様に思うのですが。 自然体で3日程度は楽勝で空くと思いますけども。 ひと月に何日くらい休みを取るのが普通な職場なんでしょうか？ 担当者リストはこっちの方が楽です（見に行くセルが一つでいいので） 　　　　　　　　　↓ 1 担当者名 当番 　　 2 佐藤 　　　　A,B,C 　　 3 鈴木　　　 A,B,C,D 4 高橋 　　　　A,B,C,D 5 田中 　　　　A,B,D ＞ＡとＢは連携して行う仕事なので、 ＞毎回同じ方との組み合わせにならないように、 ＞できる限り配慮しています。 こう言う条件は早い段階で出して頂きたいですねぇ‥ （半平太） 2023/11/22(水) 23:20:23 ---- 半平太さん 人数的には多いのですが、当番を担当される方は 全員ではありません。 一人あたりひと月１〜２日くらいが大抵ですが、 子供が長い休みに入る時などは、一週間ほど休まれる方もいます。 伝えることも遅く申し訳ないです…。 （トド） 2023/11/22(水) 23:59:45 ---- ＞ＡとＢは連携して行う仕事なので Ａが終わったらＢということでしょうか。 （?） 2023/11/23(木) 10:21:51 ---- ？さん 仕事内容に関しては説明が難しいので 申し訳ありませんが、割愛させていただきます。 毎日４人当番で、当番表を作りたいと思っています。 （トド） 2023/11/23(木) 11:41:30 ---- １．担当者リストは以下の形式とします。 <担当者リスト シート　サンプル> 行 ___A___ ___B___ _____C_____ ____D____ 1 担当者 当番 イベント1 イベント2　・・ 2 佐藤 A,B,C 2023/12/19 2023/11/1 3 鈴木 A,B,C,D 　　：：：： ２．祝日データ範囲は、「祝日リスト」と名前定義してあるものとします。 　　日付データ範囲及び未入力セル範囲とし、文字データは含めない(元日とか）。 ３．シフト表の「休」と強制当番名は、手入力であるものとします。 　　※マクロで決定した当番名は、数式の形で出力します。(手入力の当番名と区別する為） 　　強制的に当番名を手入力する場合、単独でのB指定は無いものとします。 　　A、C、Dの単独指定、および「A、B」同時指定は可能。 ４．実行は、マクロ「Main」を実行するか、シフト表の1行目のどこかしらを右クリックする。 　　通常は、満足のいくシフト表が出来るまで、シフト表の1行目を何回か右クリックすることになる。 ５．もし、出力結果を消して、元の手入力状態に戻したい場合は、マクロ「resetToOriginal」を実行する。 　　まぁ、数式を消すだけですけども。 ７．使用するマクロ (1)クラスモジュールを一枚挿入して、クラス名(オブジェクト名）を変更する。 　　Class1　→　Staff 　　当該モジュールに後記クラスモジュール用のプロシージャをコピペする。 (2）シフト表のモジュール(標準モジュールではない → 重要）に後記の 　　シートモジュール用のプロシージャをコピペする ８．コピペするモジュール 　(1)　-----------staffクラスモジュール------------ Private RwNo As String Private Name As String Private rSfRow As Range Private vSfRow As Variant Private vSfRowOut As Variant '打出し用 Private timesDone(1 To 5) '"A,B,C,D" 5=Total Private randomPos As Long Private ABcombCounterPart As Long Private ableDuties '担当可リスト Private rEventDays As Range Sub init(rSF As Range, i As Long, wsPers As Worksheet, RdAry()) Dim rowPos Set rSfRow = rSF.Rows(i) vSfRow = rSfRow.Value vSfRowOut = rSfRow.Value RwNo = Format(i, "00") Name = vSfRow(1, 2) randomPos = RdAry(i) ableDuties = Application.VLookup(Name, wsPers.Range("A2:B129"), 2, False) If IsError(ableDuties) Then ableDuties = "" End If rowPos = Application.Match(Name, wsPers.Range("A1:A129"), 0) If IsError(rowPos) Then Set rEventDays = wsPers.Range("A1000:B1000") 'Dummy Else Set rEventDays = Intersect(wsPers.UsedRange, wsPers.Rows(rowPos)) End If End Sub '優先順位作成 Function Priority(Duty, ColNum As Long, dy As Date, preDayCol(), flwDayCol(), staffChargedAForClNum) Dim Top(1 To 6) As String Dim i As Long Dim DutyPos Top(1) = "A" '仮置き 'A−Bの組合せのダブり回避 If Duty = "B" Then If ABcombCounterPart = staffChargedAForClNum Then Top(1) = "S" End If End If '3日間空けをチェック For i = 1 To 3 If vSfRow(1, preDayCol(i, ColNum)) <> "" Or _ vSfRow(1, flwDayCol(i, ColNum)) <> "" Then Top(1) = "W" Exit For End If Next If vSfRow(1, ColNum) <> "" Then '休、指定済、既決定 Top(1) = "Z" ElseIf InStr(ableDuties, Duty) = 0 Then '担当不可 Top(1) = "Z" ElseIf Application.CountIf(rEventDays, dy) Then 'イベントあり Top(1) = "Z" End If DutyPos = InStr("ABCD", Duty) Top(2) = Format(Val(timesDone(DutyPos)), "00") '当該当番の回数 If Duty = "A" Then If InStr(ableDuties, Duty) = 0 Then Top(3) = "A" End If ElseIf Duty = "B" Then If InStr(ableDuties, Duty) = 0 Then Top(3) = "B" End If Else Top(3) = "W" '通常 End If Top(4) = Format(Val(timesDone(5)), "00") 'トータル回数 Top(5) = Format(randomPos, "00") 'ランダム順 Top(6) = Format(RwNo, "00") '行番号、インスタンスNO Priority = Join(Top, "") End Function Sub countDone(Duty, ColNum As Long, staffChargedAForClNum) Dim DutyPos As Long DutyPos = InStr("ABCD", Duty) timesDone(DutyPos) = timesDone(DutyPos) + 1 timesDone(5) = timesDone(5) + 1 vSfRow(1, ColNum) = Duty vSfRowOut(1, ColNum) = "=""" & Duty & """" '数式の形にする(手入力と区別する為) If staffChargedAForClNum <> "更新不要" Then ABcombCounterPart = staffChargedAForClNum End If End Sub Sub rememberCounterPart(staffChargedBForClNum) ABcombCounterPart = staffChargedBForClNum End Sub Sub setRandomPos(Pos As Long) randomPos = Pos End Sub Function result(ColNum As Long) result = vSfRowOut(1, ColNum) End Function Private Sub Class_Terminate() Set rSfRow = Nothing Set rEventDays = Nothing End Sub 　(2)　-----------シフト表シートモジュール------------ Private staffs() As staff Private Sub Worksheet_BeforeRightClick(ByVal target As Range, Cancel As Boolean) If target.Row = 1 Then Cancel = True Call JobAssignment(target) End If End Sub Sub Main() Call JobAssignment(Worksheets("シフト表").Rows(1)) End Sub '[作業]シートと[担当者リスト]シートを1枚挿入して置く Private Sub JobAssignment(target As Range) Dim wsPersonal As Worksheet Dim rSF As Range Dim vWF Dim Duty Dim lastRw As Long Dim RWNum As Long, ColNum As Long Dim dy As Date Dim Hldy As Range Dim msgAlert As String Dim i As Long, k As Long, rr As Long Dim rDataForClNum As Range Dim duplDuty As Long Dim SrtLst As Object Dim Idx As Long Dim prevDayCols(1 To 3, 1 To 35) Dim folwDayCols(1 To 3, 1 To 35) Dim staffChargedBForClNum Dim priotryKey Dim afixedAry(4 To 35) Dim RdAry() '数式をクリアするして、元の手入力データに戻す resetToOriginal Set Hldy = Application.Range("祝日リスト") Set wsPersonal = Worksheets("担当者リスト") ' 基準列番号に対応する「3営業前後、2営業前後,1営業前後」の列番を配列に格納する With Application For i = 4 To 34 If Cells(3, i) <> "" Then prevDayCols(1, i) = .Max(3, .WorkDay(Cells(3, i), -1, Hldy) - Range("C1").Value2 + 4) prevDayCols(2, i) = .Max(3, .WorkDay(Cells(3, i), -2, Hldy) - Range("C1").Value2 + 4) prevDayCols(3, i) = .Max(3, .WorkDay(Cells(3, i), -3, Hldy) - Range("C1").Value2 + 4) folwDayCols(1, i) = .Min(35, .WorkDay(Cells(3, i), 1, Hldy) - Range("C1").Value2 + 4) folwDayCols(2, i) = .Min(35, .WorkDay(Cells(3, i), 2, Hldy) - Range("C1").Value2 + 4) folwDayCols(3, i) = .Min(35, .WorkDay(Cells(3, i), 3, Hldy) - Range("C1").Value2 + 4) End If Next i End With Set SrtLst = CreateObject("System.Collections.SortedList") lastRw = Cells(Rows.Count, "B").End(xlUp).Row Set rSF = Range("A1:AI1").Resize(lastRw) '1列余分に取得 vWF = rSF.Value RdAry = rndOrder(lastRw) '乱数生成 'staffインスタンス作成 ReDim staffs(5 To lastRw) For i = 5 To lastRw Set staffs(i) = New staff staffs(i).init rSF, i, wsPersonal, RdAry Next i '割当本番-------------------------------- Application.ScreenUpdating = False For Each Duty In Array("A", "B", "C", "D") For ColNum = 4 To 34 SrtLst.Clear dy = Val(Cells(3, ColNum).Value2) '3行目の日付を取得 If Application.NetworkDays(dy, dy, Hldy) Then '営業日のみ処理 Set rDataForClNum = Cells(1, ColNum).Resize(lastRw) '処理列を取得 duplDuty = Application.CountIf(rDataForClNum, Duty) If duplDuty > 1 Then MsgBox ColNum & "列目の当番が重複しています" Exit Sub ElseIf duplDuty = 1 Then 'イレギュラー処理(指定済みの場合) If Duty = "A" Then afixedAry(ColNum) = Application.Match(Duty, rDataForClNum, 0) staffs(afixedAry(ColNum)).countDone Duty, ColNum, "更新不要" ElseIf Duty = "B" Then staffChargedBForClNum = Application.Match(Duty, rDataForClNum, 0) staffs(staffChargedBForClNum).countDone Duty, ColNum, afixedAry(ColNum) staffs(afixedAry(ColNum)).rememberCounterPart staffChargedBForClNum End If GoTo skipThisDay End If For Idx = 5 To lastRw '5行目からレギュラー処理(=staffの1番目から） SrtLst.Add staffs(Idx).Priority(Duty, ColNum, Cells(3, ColNum), _ prevDayCols, folwDayCols, afixedAry(ColNum)), "" Next Idx For i = 0 To SrtLst.Count - 1 priotryKey = SrtLst.getkey(i) ' Debug.Print priotryKey If Left(priotryKey, 1) <> "Z" Then '割当決定 Idx = Val(Right(priotryKey, 2)) If Duty = "A" Then staffs(Idx).countDone Duty, ColNum, "更新不要" afixedAry(ColNum) = Idx ElseIf Duty = "B" Then staffs(Idx).countDone Duty, ColNum, afixedAry(ColNum) staffs(afixedAry(ColNum)).rememberCounterPart Idx Else staffs(Idx).countDone Duty, ColNum, "更新不要" End If Exit For End If If Idx >= SrtLst.Count Then msgAlert = ColNum & "列目の" & Duty & "が割当できません" & vbCrLf End If Next i End If skipThisDay: Next ColNum Next Duty showResult lastRw '試し打出し Application.ScreenUpdating = True If msgAlert <> "" Then MsgBox msgAlert Else MsgBox "完了" End If End Sub Sub resetToOriginal() Dim aCL As Range, App As Application Set App = Application With Worksheets("シフト表") On Error Resume Next Intersect(.UsedRange, .Range("D5:AH100")).SpecialCells(xlCellTypeFormulas, 23).ClearContents On Error GoTo 0 End With End Sub Private Sub showResult(lastRw As Long) Dim Idx As Long Dim ColNum As Long Dim aryOut() ReDim aryOut(5 To lastRw, 4 To 34) For ColNum = 4 To 34 For Idx = 5 To lastRw aryOut(Idx, ColNum) = staffs(Idx).result(ColNum) Next Idx Next ColNum With Worksheets("シフト表") .Range("D5").Resize(lastRw - 4, 31).FormulaLocal = aryOut .Range("AJ4:AM4") = Array("A", "B", "C", "D") .Range("AJ5:AM" & lastRw).FormulaLocal = "=COUNTIF($D5:$AH5,AJ$4)" .Range("AN5:AN" & lastRw).FormulaLocal = "=SUM(AJ5:AM5)" End With End Sub Function rndOrder(num As Long) '乱数生成 Dim rd(), orderNum(), i, rndInOrder Randomize ReDim re(1 To num) ReDim orderNum(1 To num) For i = 1 To num orderNum(i) = i re(i) = Rnd() Next i rndInOrder = Application.Small(re, orderNum) rndOrder = Application.Match(re, rndInOrder, 0) End Function （半平太） 2023/11/23(木) 19:52:09 ---- 半平太さん ありがとうございます！！ 早速試してみましたが、 prevDayCols(1, i) = .Max(3, .WorkDay(Cells(3, i), -1, Hldy) - Range("C1").Value2 + 4) この部分で「型が一致しません」というエラーがかかりました。 シフト表はこの形↓で、 A B C D E F G H I J K 1 当番表 2023年12月 2 3 1 2 3 4 5 6 7 8 4 NO 担当者 出勤日数 水 木 金 土 日 月 火 水 5 1 佐藤 休 - - 6 2 鈴木 休 - - 7 3 高橋 - - 休 8 4 田中 休 - - 休 9 5 伊藤 - - 休 … … … … … … … … … … … … 32 29 中村 - - 33 30 小林 休 - - 担当者リストなども、ご指定の通りにしました。 どのようにしたらいいでしょうか。 （トド） 2023/11/23(木) 21:35:40 ---- ＞ prevDayCols(1, i) = .Max(3, .WorkDay(Cells(3, i), -1, Hldy) - Range("C1").Value2 + 4) ＞この部分で「型が一致しません」というエラーがかかりました。 ふーむ、こんな所でエラーが出てしまうとは・・疲れますなぁ・・ 考えてみると、1行目から4行目にどんなデータ(数式）が入っているのか、 確認してなかったですねぇ。 １．C1セルは、月初日を入れてください。 　　例：2023/11/1　※セルの表示形式は何でもいいです。 ２．D1〜AH4の数式 以下のプログラムで数式を埋めてください。 Sub onlyOnce() With Sheets("シフト表") Rem 標準外書式セルをまとめて処理 .Range("D3:AH3").NumberFormatLocal = "d" .Range("D4:AH4").NumberFormatLocal = "aaa" Rem 数式セルをまとめて処理 .Range("D3").FormulaR1C1Local = "=R[-2]C[-1]" .Range("E3:AE3").FormulaR1C1Local = "=RC[-1]+1" .Range("AF3:AH3").FormulaR1C1Local = "=IF(DAY(RC[-3]+3)<7,"""",RC[-3]+3)" .Range("D4:AH4").FormulaR1C1Local = "=TEXT(R[-1]C,""AAA"")" End With End Sub それでだめなら、祝日リストが正しく名前定義されていないか、ですけども。 （半平太） 2023/11/23(木) 22:48:44 ---- 半平太さん 思ったものができていて感動しています！ ただ、コードに作業シートを挿入と書いてあったので、 作業シートを挿入しておいたのですが、白紙です。 シフト表のAJから数式が追加されてはいっています。 また、シフト表の土日祝日は 土曜は青、日曜は赤など条件付き書式設定をしているのですが、 反応しなくなってしまいました。 どのように修正したらいいでしょうか？ （トド） 2023/11/23(木) 23:29:56 ---- ＞ただ、コードに作業シートを挿入と書いてあったので、 ＞作業シートを挿入しておいたのですが、白紙です。 今回、他の質問への回答を流用したのですが、不要分の消し残しです。m(__)m ※ 「作業」シートを使わない方式にしたので、それは削除しちゃってください。 ＞土曜は青、日曜は赤など条件付き書式設定をしているのですが、 ＞反応しなくなってしまいました。 再度、下のプログラムで数式を一部変更してください。(多分、これで元に戻ります。) Private Sub onlyOnce() With Sheets("シフト表") .Range("D4:AG4").FormulaR1C1Local = "=R[-1]C" End With End Sub （半平太） 2023/11/23(木) 23:46:28 ---- 改めてテストすると、3日以上空ける要件がうまく行ってない節があります。 ちょっと、ロジックを点検してみます。 （半平太） 2023/11/24(金) 08:47:35 ---- ロジックミスがありましたので、以下に修正します。 これで、当番間隔が近すぎることはなくなると思います。 ただ、休み明け直後に当番に当たる確率が高くなった気がするので、 出来るだけそれは避けるようにしました。 トータルの当番回数が、多い人と少ない人で2回以上差がでる事が珍しくなかったので、 差が1回になるまでループさせることにしました。 ※ただし、余り長くもやってられないので、5回でループは打ち切って、結果を出力します。 　その時は、差が幾つあったか警告を出します。 　差が1回以内の場合は、警告も、完了メッセージも出しません(いちいち出すと鬱陶しいので) -------------------------クラスモジュール用------------------------- Private RwNo As String Private Name As String Private rSfRow As Range Private vSfRow As Variant Private vSfRowOut As Variant '打出し用 Private timesDone(1 To 5) '"A,B,C,D" 5=Total Private randomPos As Long Private ABcombCounterPart As Long Private ableDuties '担当可リスト Private rEventDays As Range Sub init(rSF As Range, i As Long, wsPers As Worksheet, RdAry()) Dim rowPos Set rSfRow = rSF.Rows(i) vSfRow = rSfRow.Value vSfRowOut = rSfRow.Value 'C列とAI列に相当するデータはEmptyに変える vSfRow(1, 3) = Empty vSfRow(1, 35) = Empty RwNo = Format(i, "00") Name = vSfRow(1, 2) randomPos = RdAry(i) ableDuties = Application.VLookup(Name, wsPers.Range("A2:B129"), 2, False) If IsError(ableDuties) Then ableDuties = "" End If rowPos = Application.Match(Name, wsPers.Range("A1:A129"), 0) If IsError(rowPos) Then Set rEventDays = wsPers.Range("A1000:B1000") 'Dummy Else Set rEventDays = Intersect(wsPers.UsedRange, wsPers.Rows(rowPos)) End If End Sub '優先順位作成 Function Priority(Duty, ColNum As Long, dy As Date, preDayCol(), flwDayCol(), staffChargedAForClNum) Dim Top(1 To 6) As String Dim i As Long Dim DutyPos Dim ck(1 To 2) Top(1) = "A" '仮置き 'A−Bの組合せのダブり回避 If Duty = "B" Then If ABcombCounterPart = staffChargedAForClNum Then Top(1) = "J" End If End If '3日間空けをチェック For i = 3 To 1 Step -1 ck(1) = vSfRow(1, preDayCol(i, ColNum)) ck(2) = vSfRow(1, flwDayCol(i, ColNum)) If InStr("ABCD", IIf(ck(1) = "", "G", ck(1))) Or _ InStr("ABCD", IIf(ck(2) = "", "G", ck(1))) Then Top(1) = Mid("PNL", i, 1) ' Debug.Print ColNum, Duty, RwNo, Name, Top(1): Stop End If Next '休み明け直後は出来れば避ける If InStr(vSfRow(1, preDayCol(1, ColNum)), "休") Then Top(1) = "Q" End If If vSfRow(1, ColNum) <> "" Then '休、指定済、既決定 Top(1) = "Z" ElseIf InStr(ableDuties, Duty) = 0 Then '担当不可 Top(1) = "Z" ElseIf Application.CountIf(rEventDays, dy) Then 'イベントあり Top(1) = "Z" End If DutyPos = InStr("ABCD", Duty) Top(2) = Format(Val(timesDone(DutyPos)), "00") '当該当番の回数 Top(3) = "W" '仮置き If Duty = "A" Then If InStr(ableDuties, Duty) = 0 Then Top(3) = "A" End If ElseIf Duty = "B" Then If InStr(ableDuties, Duty) = 0 Then Top(3) = "B" End If Else Top(3) = "W" '通常 End If Top(4) = Format(Val(timesDone(5)), "00") 'トータル回数 Top(5) = Format(randomPos, "00") 'ランダム順 Top(6) = Format(RwNo, "00") '行番号、インスタンスNO Priority = Join(Top, "") End Function Sub countDone(Duty, ColNum As Long, staffChargedAForClNum) Dim DutyPos As Long DutyPos = InStr("ABCD", Duty) timesDone(DutyPos) = timesDone(DutyPos) + 1 timesDone(5) = timesDone(5) + 1 vSfRow(1, ColNum) = Duty vSfRowOut(1, ColNum) = "=""" & Duty & """" '数式の形にする(手入力と区別する為) If staffChargedAForClNum <> "更新不要" Then ABcombCounterPart = staffChargedAForClNum End If End Sub Sub rememberCounterPart(staffChargedBForClNum) ABcombCounterPart = staffChargedBForClNum End Sub Sub setRandomPos(Pos As Long) randomPos = Pos End Sub Function result(ColNum As Long) result = vSfRowOut(1, ColNum) End Function Function ttlDone() ttlDone = timesDone(5) End Function Private Sub Class_Terminate() Set rSfRow = Nothing Set rEventDays = Nothing End Sub -------------------------シフト表モジュール用------------------------- Private staffs() As staff Private Sub Worksheet_BeforeRightClick(ByVal target As Range, Cancel As Boolean) If target.Row = 1 Then Cancel = True Call JobAssignment End If End Sub Sub Main() Call JobAssignment End Sub Private Sub JobAssignment() Dim wsPersonal As Worksheet Dim rSF As Range Dim vWF Dim Duty Dim lastRw As Long Dim RWNum As Long, ColNum As Long Dim dy As Date Dim Hldy As Range Dim msgAlert As String Dim i As Long, k As Long, rr As Long Dim rDataForClNum As Range Dim duplDuty As Long Dim SrtLst As Object Dim Idx As Long Dim prevDayCols(1 To 3, 1 To 35) Dim folwDayCols(1 To 3, 1 To 35) Dim staffChargedBForClNum Dim priotryKey Dim afixedAry(4 To 35) Dim RdAry() Dim Mx As Long, Mn As Long, Cycle '数式をクリアするして、元の手入力データに戻す resetToOriginal Set Hldy = Application.Range("祝日リスト") Set wsPersonal = Worksheets("担当者リスト") ' 基準列番号に対応する「3営業前後、2営業前後,1営業前後」の列番を配列に格納する With Application For i = 4 To 34 If Cells(3, i) <> "" Then prevDayCols(1, i) = .Max(3, .WorkDay(Cells(3, i), -1, Hldy) - Range("C1").Value2 + 4) prevDayCols(2, i) = .Max(3, .WorkDay(Cells(3, i), -2, Hldy) - Range("C1").Value2 + 4) prevDayCols(3, i) = .Max(3, .WorkDay(Cells(3, i), -3, Hldy) - Range("C1").Value2 + 4) folwDayCols(1, i) = .Min(35, .WorkDay(Cells(3, i), 1, Hldy) - Range("C1").Value2 + 4) folwDayCols(2, i) = .Min(35, .WorkDay(Cells(3, i), 2, Hldy) - Range("C1").Value2 + 4) folwDayCols(3, i) = .Min(35, .WorkDay(Cells(3, i), 3, Hldy) - Range("C1").Value2 + 4) End If Next i End With Set SrtLst = CreateObject("System.Collections.SortedList") lastRw = Cells(Rows.Count, "B").End(xlUp).Row For Cycle = 1 To 5 SrtLst.Clear RdAry = rndOrder(lastRw) '乱数生成 Set rSF = Range("A1:AI1").Resize(lastRw) '1列余分に取得 'staffインスタンス作成 ReDim staffs(5 To lastRw) For i = 5 To lastRw Set staffs(i) = New staff staffs(i).init rSF, i, wsPersonal, RdAry Next i '割当本番-------------------------------- Application.ScreenUpdating = False For Each Duty In Array("A", "B", "C", "D") For ColNum = 4 To 34 SrtLst.Clear dy = Val(Cells(3, ColNum).Value2) '3行目の日付を取得 If Application.NetworkDays(dy, dy, Hldy) Then '営業日のみ処理 Set rDataForClNum = Cells(1, ColNum).Resize(lastRw) '処理列を取得 duplDuty = Application.CountIf(rDataForClNum, Duty) If duplDuty > 1 Then MsgBox ColNum & "列目の当番が重複しています" Exit Sub ElseIf duplDuty = 1 Then 'イレギュラー処理(指定済みの場合) If Duty = "A" Then afixedAry(ColNum) = Application.Match(Duty, rDataForClNum, 0) staffs(afixedAry(ColNum)).countDone Duty, ColNum, "更新不要" ElseIf Duty = "B" Then staffChargedBForClNum = Application.Match(Duty, rDataForClNum, 0) staffs(staffChargedBForClNum).countDone Duty, ColNum, afixedAry(ColNum) staffs(afixedAry(ColNum)).rememberCounterPart staffChargedBForClNum End If GoTo skipThisDay End If For Idx = 5 To lastRw '5行目からレギュラー処理(=staffの1番目から） SrtLst.Add staffs(Idx).Priority(Duty, ColNum, Cells(3, ColNum), _ prevDayCols, folwDayCols, afixedAry(ColNum)), "" Next Idx priotryKey = SrtLst.getkey(0) If Left(priotryKey, 1) <> "Z" Then '割当決定 Idx = Val(Right(priotryKey, 2)) If Duty = "A" Then staffs(Idx).countDone Duty, ColNum, "更新不要" afixedAry(ColNum) = Idx ElseIf Duty = "B" Then staffs(Idx).countDone Duty, ColNum, afixedAry(ColNum) staffs(afixedAry(ColNum)).rememberCounterPart Idx Else staffs(Idx).countDone Duty, ColNum, "更新不要" End If Else msgAlert = msgAlert & ColNum & "列目の" & Duty & "が割当できません" & vbCrLf End If End If skipThisDay: Next ColNum Next Duty Mx = 1 Mn = 100 For Idx = 5 To lastRw If staffs(Idx).ttlDone > 0 Then Mn = Application.Min(Mn, staffs(Idx).ttlDone) Mx = Application.Max(Mx, staffs(Idx).ttlDone) End If Next 'Debug.Print Mx, Mn If Mx - Mn <= 1 Then Exit For End If SrtLst.Clear Next Cycle showResult lastRw Erase staffs() If Mx - Mn > 1 Then msgAlert = msgAlert & "最多回数 - 最少回数　=" & (Mx - Mn) End If Application.ScreenUpdating = True If msgAlert <> "" Then MsgBox msgAlert End If End Sub Sub resetToOriginal() Dim aCL As Range, App As Application Set App = Application With Worksheets("シフト表") On Error Resume Next Intersect(.UsedRange, .Range("D5:AH100")).SpecialCells(xlCellTypeFormulas, 23).ClearContents On Error GoTo 0 End With End Sub Private Sub showResult(lastRw As Long) Dim Idx As Long Dim ColNum As Long Dim aryOut() ReDim aryOut(5 To lastRw, 4 To 34) For ColNum = 4 To 34 For Idx = 5 To lastRw aryOut(Idx, ColNum) = staffs(Idx).result(ColNum) Next Idx Next ColNum With Worksheets("シフト表") .Range("D5").Resize(lastRw - 4, 31).FormulaLocal = aryOut .Range("AJ4:AM4") = Array("A", "B", "C", "D") .Range("AJ5:AM" & lastRw).FormulaLocal = "=COUNTIF($D5:$AH5,AJ$4)" .Range("AN5:AN" & lastRw).FormulaLocal = "=SUM(AJ5:AM5)" End With End Sub Function rndOrder(num As Long) '乱数生成 Dim rd(), orderNum(), i, rndInOrder Randomize ReDim re(1 To num) ReDim orderNum(1 To num) For i = 1 To num orderNum(i) = i re(i) = Rnd() Next i rndInOrder = Application.Small(re, orderNum) rndOrder = Application.Match(re, rndInOrder, 0) End Function （半平太） 2023/11/24(金) 13:52:17 ---- 半平太さん 改めてコードを教えて下さりありがとうございます！ やはり条件を設定した書式が反映されないのですが、 何が考えられますでしょうかね。 （トド） 2023/11/24(金) 19:37:14 ---- どんな条件付き書式が設定されているのか、３色に関する設定情報がないとこちらではこれ以上分かりません。 もしくは、下のマクロで、「従来の条件付き書式を消去して、新たに3つの条件付き書式を設定」するか。 Sub setFormatCondition() Dim ws As Worksheet Set ws = Worksheets("シフト表") With ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp)).Resize(, 31).Offset(, 2) '条件付き書式を消去 .FormatConditions.Delete '３色を新規設定 .FormatConditions.Add Type:=xlExpression, Formula1:="=WEEKDAY(D$3)=7" .FormatConditions.Add Type:=xlExpression, Formula1:="=WEEKDAY(D$3)=1" .FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF(祝日リスト,D$3*1)" .FormatConditions(1).Interior.Color = RGB(0, 255, 255) .FormatConditions(2).Interior.Color = RGB(255, 150, 200) .FormatConditions(3).Interior.Color = RGB(0, 255, 0) End With End Sub （半平太） 2023/11/24(金) 21:03:03 ---- 半平太さん ありがとうございます。 解決しました！ 教えてください。 「強制的に当番名を手入力する場合、単独でのB指定は無いものとします。」 これはどういった意味でしょうか。 A、B、C、Dなどの表記にしましたが、本来は当番に名前があり、 担当者リストにも当番名が入力されているのですが、 本来の当番の名前には直せないということですか？ 名前の変更はできるけど、 A当番はB当番と連携する仕事なので、Bだけで仕事することはないから、 Bだけの仕事指定はできないという意味でしょうか。 （トド） 2023/11/24(金) 21:46:29 ---- ＞「強制的に当番名を手入力する場合、単独でのB指定は無いものとします。」 ＞これはどういった意味でしょうか 当番Aから決めていく方針なので、Aが決まる前に先にBを決めることは出来ない、と言う意味です。 CやDは、Aと何も関係ないので、自由に決められますが、 AとBはお互いに組になったことを覚えていなければならない間柄なので、 Bが決まったときにAがまだ決まってないと言う事態を想定しておりません。 ＞A、B、C、Dなどの表記にしましたが、本来は当番に名前があり、 ＞担当者リストにも当番名が入力されているのですが、 ＞本来の当番の名前には直せないということですか？ 本当の当番名ではないと言うのは、想定しておりませんでしたので、 どうなるか分かりません。試してみる気もありません。申し訳ないです。m(__)m （半平太） 2023/11/24(金) 22:39:34 ---- 半平太さん わかりやすく教えて下さりありがとうございます！ このような素晴らしいVBAを考えて下さり、ありがとうございます。 当番名はこのコードが使えるように考えます。 本当にありがとうございました。 （トド） 2023/11/24(金) 23:30:32