『当番の割り当て』（今月ゴミ当番）

『当番の割り当て』
https://www.excel.studio-kazu.jp/kw/20231020232949.html

以前当番の割り当てについて質問しました('◇')ゞ


ここで教えて下さった当番表を使用して、
本当にサクサク…サクサクと割り当てができているのですが、
早退や遅刻の人が電話当番に当たっていないみたいなんです！

・・・いつも指摘してくる人に指摘されました(＠_＠;)


どこを修正したら、早退や遅刻の方も
割り当てられるようになりますか？


それから、
以前の質問に「ハムさん」が質問されていましたが、
私も知りたいです(*^▽^*)
この当番表の一番上の行を２列改行して、
タイトルをつけたいと思っているので、
どうかどうか教えていただけませんか？

よろしくお願いします！！<(_ _)><(_ _)><(_ _)>



＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
----
 ＞以前当番の割り当てについて質問しました
 
 記憶が消えかかっているなぁー
 、
 ＞早退や遅刻の人が電話当番に当たっていないみたいなんです！
 なるほど鋭い。
 ロジックからすると、かなり当たらない人になっちゃってますね・・
 (絶対やらないって訳じゃない、くらいのニュアンス）
 
 １．マクロ　Private Sub JobAssignment(target As Range)　内の
 　　以下の2行を、その下の14行で上書き
 
 ＞    Case "早", "遅"
 ＞        strToSort(rr, 1) = "X"
 　　　　↓
 
       Case "早"
           Select Case kbn
               Case "ト", "消", "会", "給", "話"
                   strToSort(rr, 1) = "Z"
               Case "電"
                   strToSort(rr, 1) = "A"
           End Select
           
       Case "遅"
           Select Case kbn
               Case "ト", "消", "会", "給", "電"
                   strToSort(rr, 1) = "Z"
               Case "話"
                   strToSort(rr, 1) = "A"
           End Select
 
 ２．同じく、マクロ　Private Sub JobAssignment(target As Range)　内の
 　　以下の4行を、その下の6行で上書き
 
 ＞         If Len(vWK(nativeRw, CLNum)) > 1 Then
 ＞              msgAlert = msgAlert & vbCrLf & "「" & vWK(nativeRw, 2) & "」さん" & _
 ＞                     vWK(nativeRw, CLNum) & "on " & Format(dy, "m月d日")
 ＞         End If
 　　　　　　　↓
 
          If Len(vWK(nativeRw, CLNum)) > 1 And _
             Not vWK(nativeRw, CLNum) = "早電" And _
             Not vWK(nativeRw, CLNum) = "遅話" Then
              
               msgAlert = msgAlert & vbCrLf & "「" & vWK(nativeRw, 2) & "」さん" & _
                      vWK(nativeRw, CLNum) & "on " & Format(dy, "m月d日")
          End If
 
 ＞それから、
 ＞以前の質問に「ハムさん」が質問されていましたが、
 ＞私も知りたいです(*^▽^*)
 
 全く乗り気になりません。悪しからず。
 
 ※処理前に2行削除して、処理後に2行追加すればいいだけなので。
 　手作業でも出来ますし、それをマクロの記録に録ればコードも作れます。
 
 
（半平太） 2023/11/28(火) 09:54:29
----
半平太さん

こんばんは！

うすれた記憶を思い出してくださって

ありがとうございます(*^▽^*)


早速試してみたら→の場所でエラーがでてしまいました(＠_＠;)

「コンパイルエラー

　Nextに対するForがありません。」



 →　Next rr

                 Set rngSorted = wsWK.Range("BB1:BB" & lastRw)

                 For M = 3 To lastRw '優先順項目結合
                     strToSort(M, 1) = strToSort(M, 1) & Format(wsWK.Cells(M, "AY"), "0000")
                     wsWK.Range("BB3:BB" & lastRw) = strToSort
                 Next



アドバイスもくださってありがとうございます！！
（今月ゴミ当番） 2023/11/28(火) 20:52:46
----
     End Select を一つ余分に消さなかったですか？
 
 
 ＞       Case "遅"
 ＞           Select Case kbn
 ＞               Case "ト", "消", "会", "給", "電"
 ＞                   strToSort(rr, 1) = "Z"
 ＞               Case "話"
 ＞                   strToSort(rr, 1) = "A"
 ＞           End Select
 　　　　　　　↑
 この下に、もう一つ(元々あった）　End Select　が残ってないとマズいです。
 
 
（半平太） 2023/11/28(火) 21:38:10
----
半平太さん


全部一つ一つ確認したのに、
同じところでエラーがでて、わかりません！( ﾉД`)ｼｸｼｸ…

申し訳ないのですが、助けてほしいです！！
コードをのせるので、どこがまちがっているか、
確認していただいてもいいですか？



Enum COL '使うシーンは、ほぼ無い
     済 = 1
     総 = 2
     ト
     電
     話
     消
     会
     給
 End Enum

 Private Sub Worksheet_BeforeRightClick(ByVal target As Range, Cancel As Boolean)
     If target.Address(0, 0) = "C2" Then
         Cancel = True
         Call JobAssignment(target)
     End If

 End Sub

 Sub Main()
     Call JobAssignment(Worksheets("シフト表").Range("C2"))
 End Sub

 '[作業]シートと[除外リスト]シートを1枚挿入して置く
 Private Sub JobAssignment(target As Range)
     Dim wsShift As Worksheet, wsWK As Worksheet, wsTel As Worksheet
     Dim rWK As Range
     Dim vWK
     Dim vNumCK()
     Dim vNGCK()
     Dim vAdj()
     Dim lastRw As Long
     Dim RWNum As Long, CLNum As Long
     Dim rngSorted As Range
     Dim cnt As Long
     Dim kbn
     Dim rwHit As Long
     Dim dy As Date
     Dim Hldy As Range
     Dim msgAlert As String
     Dim i As Long, k As Long, rr As Long, M As Long
     Dim Limit As Long, limitFixed(1 To 8)
     Dim POS
     Dim nativeRw As Long
     Dim strToSort()
     Dim Tel, temp(1 To 9)
     Dim dicT As Object
     Dim DataForTheDay As Range
     Dim previousDayCol(1 To 3, 1 To 33) As Long
     Dim medNum()
     Dim daysOff As Long

     Set Hldy = Application.Range("祝日リスト")
     Set wsShift = Worksheets("シフト表")
     Set wsWK = Worksheets("作業")
     Set wsTel = Worksheets("電話当番")
     Set dicT = CreateObject("Scripting.Dictionary")

     wsWK.UsedRange.Clear

     'シフト表("A:AH")を作業シートに転記する
     Call resetToOriginal 'シフト表を初期状態に戻す
     Intersect(wsShift.UsedRange, wsShift.Range("A1:AG100")).Copy wsWK.Range("A1")

     With wsWK    'AG列までデータを格納
         lastRw = wsWK.Cells(.Rows.Count, "B").End(xlUp).Row
         Set rWK = .Range("A1:A" & lastRw).Resize(, 33)
         vWK = rWK.Value
     End With

     'チェック用数式の入力と監視用配列の確保
     wsWK.Range("BB1") = target.Column
     inputFmlOnce wsWK, rWK.Rows.Count - 2 '3行目からが数式入力の為、マイナス2行とする

     vNumCK = rWK.Range("AI1:AP1").Resize(lastRw).Value
     vNGCK = rWK.Range("AQ1:AX1").Resize(lastRw).Value
     vAdj = rWK.Range("BD1:BK1").Resize(lastRw).Value

         '3営業前、2営業前,1営業前の列番号を配列に格納する
     With Application
         For i = 3 To 33
             If wsWK.Cells(2, i) <> "" Then
                 previousDayCol(1, i) = .Max(2, .WorkDay(wsWK.Cells(2, i), -1, Hldy) - rWK.Range("B1").Value2 + 3)
                 previousDayCol(2, i) = .Max(2, .WorkDay(wsWK.Cells(2, i), -2, Hldy) - rWK.Range("B1").Value2 + 3)
                 previousDayCol(3, i) = .Max(2, .WorkDay(wsWK.Cells(2, i), -3, Hldy) - rWK.Range("B1").Value2 + 3)
             End If
         Next i
     End With

     '割会本番--------------------------------
     Application.ScreenUpdating = False
shuffle wsWK, rWK.Rows.Count - 2
     For CLNum = target.Column To 33
         Set DataForTheDay = rWK.Cells(1, CLNum).Resize(lastRw)

         '前日までの当番累計を書き出し
          wsWK.Range("AI1").Resize(UBound(vNumCK), UBound(vNumCK, 2)) = vNumCK '前日までの累を計書き出す

         '前日までの当番別累計の中央値を格納する
         ReDim medNum(1 To 8)

         For i = 2 To 8 '総→給
             medNum(i) = Application.Median(wsWK.Range("AH3").Offset(0, i).Resize(lastRw - 2))
             If IsError(medNum(i)) Then
                 medNum(i) = 0
             End If
         Next i

         '営業日チェック
         If vWK(2, CLNum) <> "" Then
             dy = vWK(2, CLNum) '2行目の曜日から日付を取得

             If Application.NetworkDays(dy, dy, Hldy) = 1 Then '平日なら
                 wsWK.Range("BB1") = CLNum '対象列を記入

                 '水増し処理
                 For k = 3 To lastRw
                     Select Case vWK(k, CLNum) '会日の当番
                         Case "休", "早々", "遅々", "-", "在": 'doNothing

                         Case Else '3連続前営業日が休かチェック
                             If vWK(k, previousDayCol(1, CLNum)) = "在" Then
                                    Call doAdjust(k, vNumCK, medNum, vAdj)
                             Else
                                 daysOff = 0

                                 For M = 1 To 3
                                     Select Case vWK(k, previousDayCol(M, CLNum))
                                         Case "休", "早々", "遅々", "-":    daysOff = daysOff + 1
                                     End Select
                                 Next M

                                 If daysOff = 3 Then
                                    Call doAdjust(k, vNumCK, medNum, vAdj)
                                 End If
                             End If
                     End Select
                 Next k

                 If CLNum > 3 Then  '除外リストのアップデート(必要ならば）
                     If IsNumeric(Application.Match(rWK.Cells(2, rWK.Range("BB1").Value), _
                         Worksheets("除外リスト").Range("A2:AG2"), 0)) Then
                     inputFmlUpdate wsWK, rWK.Rows.Count - 2
                     vNGCK = rWK.Range("AQ1:AX1").Resize(lastRw).Value
                 End If
             End If

             '管理者指定当番があるかチェック
             Erase limitFixed

             '管理者指定当番：即確定
             For rr = 3 To lastRw
                 If vWK(rr, CLNum) <> "" Then
                     POS = InStr("DDト電話消会給", Left(vWK(rr, CLNum), 1))

                     If POS > 2 Then
                         vNumCK(rr, 総) = vNumCK(rr, 総) + 1
                         vNumCK(rr, POS) = vNumCK(rr, POS) + 1
                         limitFixed(POS) = limitFixed(POS) + 1
                     End If
                  End If
                 Next rr
 '視認の為
 'wsWK.Cells(1, "AI").Resize(lastRw, 8) = vNumCK

             For i = 3 To 8  'ト-電-話-消-会-給
                 kbn = Mid("DDト電話消会給", i, 1)
                 ReDim strToSort(3 To lastRw, 1 To 1)

                 '優先順項目作成
                 For rr = 3 To lastRw
                     strToSort(rr, 1) = IIf(Len(vWK(rr, CLNum)) >= 1, "Y", "A")

                     Select Case kbn
                         Case "電"
                             If InStr(vWK(rr, CLNum), "遅") Then
                                 strToSort(rr, 1) = "Z"
                             End If

                         Case "話"
                             If InStr(vWK(rr, CLNum), "早") Then
                                 strToSort(rr, 1) = "Z"
                             ElseIf InStr(vNumCK(rr, i), "電") Then
                                 strToSort(rr, 1) = "Z"
                             ElseIf InStr(vNumCK(rr, i), "消") Then
                                 strToSort(rr, 1) = "Z"
                             End If
                     End Select

                     Select Case vWK(rr, rWK.Range("BB1").Value)
                         Case "休", "早々", "遅々", "-", "在"
                             strToSort(rr, 1) = "Z"

                         Case "早"
           Select Case kbn
               Case "ト", "消", "会", "給", "話"
                   strToSort(rr, 1) = "Z"
               Case "電"
                   strToSort(rr, 1) = "A"
           End Select

       Case "遅"
           Select Case kbn
               Case "ト", "消", "会", "給", "電"
                   strToSort(rr, 1) = "Z"
               Case "話"
                   strToSort(rr, 1) = "A"
           End Select

                     If vNGCK(rr, i) = "Z" Then
                         strToSort(rr, 1) = "Z"
                     End If

                    strToSort(rr, 1) = strToSort(rr, 1) & Format(vNumCK(rr, 2) + 100 * vNumCK(rr, i), "0000")
                 Next rr

                 Set rngSorted = wsWK.Range("BB1:BB" & lastRw)

                 For M = 3 To lastRw '優先順項目結合
                     strToSort(M, 1) = strToSort(M, 1) & Format(wsWK.Cells(M, "AY"), "0000")
                     wsWK.Range("BB3:BB" & lastRw) = strToSort
                 Next

                 With wsWK.Sort
                     .SortFields.Clear
                     .SortFields.Add Key:=wsWK.Range("BB2"), SortOn:=xlSortOnValues, _
                     Order:=xlAscending, DataOption:=xlSortNormal

                     .SetRange wsWK.Range("BB2:BB" & lastRw)
                     .Header = xlYes
                     .Apply
                 End With

                 Limit = IIf(kbn = "電" Or kbn = "話", 3, 1)

                 '管理者が指定した当番を差し引く
                 Limit = Limit - limitFixed(i)
                 If Limit < 0 Then
                     MsgBox "強制当番数が多すぎです " & CLNum - 2 & "日の「" & Mid("DDト電話消会給", i, 1) & "」"
                     Exit Sub
                 End If

                 If Limit > 0 Then
                     cnt = 0

                     For k = 3 To lastRw
                         If Left(rngSorted(k, 1), 1) <> "Z" Then
                             cnt = cnt + 1
                             nativeRw = Val(Right(rngSorted(k, 1), 2))

                             vNumCK(nativeRw, 総) = vNumCK(nativeRw, 総) + 1
                             vNumCK(nativeRw, i) = vNumCK(nativeRw, i) + 1

                             vWK(nativeRw, CLNum) = vWK(nativeRw, CLNum) & kbn

If Len(vWK(nativeRw, CLNum)) > 1 And _
             Not vWK(nativeRw, CLNum) = "早電" And _
             Not vWK(nativeRw, CLNum) = "遅話" Then

               msgAlert = msgAlert & vbCrLf & "「" & vWK(nativeRw, 2) & "」さん" & _
                      vWK(nativeRw, CLNum) & "on " & Format(dy, "m月d日")
          End If

                             If cnt >= Limit Then
                                 Exit For
                             End If
                         End If
                     Next k

                     If k > lastRw Then
                         msgAlert = msgAlert & vbCrLf & "「" & kbn & "」の対象者不在　on " & Format(dy, "m月d日")
                     End If
                 End If
             Next i
         End If
     End If

     For i = 3 To lastRw '決定フラグ初期化
         vNumCK(i, 済) = Empty
     Next

     '視認の為
 '     wsWK.Range("A1").Resize(UBound(vWK), UBound(vWK, 2)) = vWK '割振り予定(文字表示)
 '     wsWK.Range("AI1").Resize(UBound(vNumCK), UBound(vNumCK, 2)) = vNumCK '集計

     Next CLNum

     wsWK.Range("A1").Resize(UBound(vWK), UBound(vWK, 2)) = vWK '割振り予定(文字表示)
     wsWK.Range("AI1").Resize(UBound(vNumCK), UBound(vNumCK, 2)) = vNumCK '集計
     wsWK.Range("BD1").Resize(UBound(vAdj), UBound(vAdj, 2)) = vAdj '水増し回数

     '    シフト表を色付け & 当番表作成------------------------
     For CLNum = target.Column To 33
         For RWNum = 3 To lastRw
             If vWK(RWNum, CLNum) <> "" And wsShift.Cells(RWNum, CLNum) = "" Then
                 Select Case True
                     Case InStr(vWK(RWNum, CLNum), "ト")
                         wsShift.Cells(RWNum, CLNum).Interior.Color = 65585
                         wsShift.Cells(RWNum, CLNum).FormulaLocal = "=""ト"""
                     Case InStr(vWK(RWNum, CLNum), "消"): wsShift.Cells(RWNum, CLNum).Interior.Color = 14083324
                     Case InStr(vWK(RWNum, CLNum), "会"): wsShift.Cells(RWNum, CLNum).Interior.Color = 14348258
                     Case InStr(vWK(RWNum, CLNum), "給"): wsShift.Cells(RWNum, CLNum).Interior.Color = 13408767
                 End Select
             End If
                 If Not dicT.exists(vWK(2, CLNum)) Then
                     Erase temp
                     temp(1) = vWK(2, CLNum)
                     dicT(vWK(2, CLNum)) = temp
                 End If
 'If CLNum = 29 Then Stop
                 If InStr(vWK(RWNum, CLNum), "電") Then
                     Tel = dicT(vWK(2, CLNum))
                     Tel(8) = Tel(8) + 1
                     Tel(1 + Tel(8)) = vWK(RWNum, 2)
                     dicT(vWK(2, CLNum)) = Tel

                 ElseIf InStr(vWK(RWNum, CLNum), "話") Then
                     Tel = dicT(vWK(2, CLNum))
                     Tel(9) = Tel(9) + 1
                     Tel(4 + Tel(9)) = vWK(RWNum, 2)
                     dicT(vWK(2, CLNum)) = Tel
                 End If

         Next RWNum
     Next CLNum

     wsTel.UsedRange.Offset(1).Resize(, 7).ClearContents
     wsTel.Range("A2:G2").Resize(dicT.Count) = Application.Index(dicT.items, 0, 0)

     Application.ScreenUpdating = True

     dicT.RemoveAll

     If msgAlert <> "" Then
         MsgBox msgAlert
     Else
         MsgBox "完了"
     End If
 End Sub

 Private Sub inputFmlOnce(wsWK As Worksheet, RW As Long)

     wsWK.Range("AI1:AX1") = [{1,2,3,4,5,6,7,8,1,2,3,4,5,6,7,8}]
     wsWK.Range("BD1:BK1") = [{1,2,3,4,5,6,7,8}]
     Worksheets("除外リスト").Range("C2").FormulaLocal = "=シフト表!C2"  '日付強制

     wsWK.Range("AI2:AP2") = Array("済", "総", "ト", "電", "話", "消", "会", "給")
     wsWK.Range("AS2:BB2") = Array("ト", "電", "話", "消", "会", "給", "乱順＆行", "乱数", "", "Sort")
     wsWK.Range("BD2:BK2") = Array("水増", "総", "ト", "電", "話", "消", "会", "給")

     wsWK.Range("AS3").Resize(RW, 6).FormulaLocal = "=IF(COUNTIF(除外リスト!$A:$A,$B3)," & _
                     "IF(ISNUMBER(FIND(AS$2,VLOOKUP($B3,除外リスト!$A$1:$C$100,3,FALSE))),""Z"",""M""),""M"")"
     wsWK.Range("AS3").Resize(RW, 6) = wsWK.Range("AS3").Resize(RW, 6).Value

     wsWK.Range("AZ3").Resize(RW).FormulaLocal = "=RAND()"
     wsWK.Range("AZ3").Resize(RW) = wsWK.Range("AZ3").Resize(RW).Value

     wsWK.Range("AY3").Resize(RW).FormulaLocal = "=RANK(AZ3,AZ$3:AZ$" & RW + 2 & ")*100+ROW()"
     wsWK.Range("AY3").Resize(RW) = wsWK.Range("AY3").Resize(RW).Value
 End Sub

 Private Sub inputFmlUpdate(wsWK As Worksheet, RW As Long)
     Dim POS As Long

    POS = Application.Match(wsWK.Cells(2, wsWK.Range("BB1").Value), Worksheets("除外リスト").Range("A2:AG2"), 0)
     wsWK.Range("AS3").Resize(RW, 6).FormulaLocal = "=IF(COUNTIF(除外リスト!$A:$A,$B3)," & _
                 "IF(ISNUMBER(FIND(AS$2,VLOOKUP($B3,除外リスト!$A$1:$AG$100," & POS & ",FALSE))),""Z"",""M""),""M"")"

     wsWK.Range("AS3").Resize(RW, 6) = wsWK.Range("AS3").Resize(RW, 6).Value
 End Sub

 Sub resetToOriginal()
     Dim aCL As Range, App As Application

     Set App = Application

     With Worksheets("シフト表")
         On Error Resume Next
         Intersect(.UsedRange, .Range("A3:AG100")).SpecialCells(xlCellTypeFormulas, 23).ClearContents
         On Error GoTo 0

         For Each aCL In Intersect(.UsedRange, .Range("A1:AG100")).Columns
             If IsNumeric(aCL.Cells(2, 1)) Then
                 If App.NetworkDays(aCL.Cells(2, 1), aCL.Cells(2, 1), App.Range("祝日リスト")) = 1 Then
                     aCL.Interior.Color = 16777215
                 End If
             End If
         Next aCL
     End With
 End Sub

 '中央値に調整
 Private Sub doAdjust(rr, vNum(), medNum, vAdj())
     Dim cc As Long

     For cc = 2 To 8
      vAdj(rr, cc) = vAdj(rr, cc) + medNum(cc) - vNum(rr, cc)
      vNum(rr, cc) = medNum(cc)
     Next cc
 End Sub

 Private Sub shuffle(wsWK As Worksheet, RW As Long)
     wsWK.Range("AZ3").Resize(RW).FormulaLocal = "=RAND()"
     wsWK.Range("AZ3").Resize(RW) = wsWK.Range("AZ3").Resize(RW).Value

     wsWK.Range("AY3").Resize(RW).FormulaLocal = "=RANK(AZ3,AZ$3:AZ$" & RW + 2 & ")*100+ROW()"
     wsWK.Range("AY3").Resize(RW) = wsWK.Range("AY3").Resize(RW).Value
 End Sub

（今月ゴミ当番） 2023/11/29(水) 19:30:27
----
       Case "遅"
           Select Case kbn
               Case "ト", "消", "会", "給", "電"
                   strToSort(rr, 1) = "Z"
               Case "話"
                   strToSort(rr, 1) = "A"
           End Select
       End Select
　　　　　　↑
       2つ目の「End Select」が抜けている、と言っているんですけども。(同じものを２つ連続して書く)

（半平太） 2023/11/29(水) 19:58:50
----
半平太さん

す、すみません。
そいうことでしたか。
できました(*^▽^*)
ありがとうございました〜〜！！
（今月ゴミ当番） 2023/11/29(水) 20:09:01