１．出勤日数と〇の数は同じですか？
　　それとも、〇は本人の出勤可能日を表し、
　　出勤日数は本人の出勤希望日数を表しているのですか？
　　(つまり、〇の数＞＝出勤日数　の関係にあるのですか？）

２．○印は、「記号の○」ですか？　それとも「漢字の〇」ですか？

３．A1セルの日付は、必ず月初ですね（祝祭日であろうがなかろうが）

４．アルファベットのA,B,Cは、ホントのデータですか？
　　それとも、別の文字だったり、３つとは限らなかったり(月によって変動したりとか）しますか？

５．祝祭日のリストは、どこかに作成されているんですか？
　　通常だと、タイトルを除く日付範囲が名前定義されているものなのですが(「祝日」とか）。

６．連続勤務回避は、同じ週内で判断するらしいので、
　　切り口を変えると、火曜または木曜が祝日だったら
　　全く問題にならないと理解していいですね？
　　(それとも、祝日は連続を中断しないものとして扱うのですか？）

＞〇の数＋数字の数＝15日の出勤日数
数字(有休）も出勤日数にカウントするとは思わなかったです。

15日というのは、本当に目標なのですか？
(通例それくらいになると言う話ではないんですか？）

※A,B,Cに基づく当月の○数はほぼ決まっているハズである所に
　流動的な有休数と職員数を加味した場合
　　有休が増えれば、出勤日数は増加気味になるし、
　　職員が増えれば、出勤日数は減少傾向になるハズなので
　　15日きっちり合わせに行くのは無理な気がするんですが・・

＞日数は厳守となっております。
分かりました。

＞マクロの自動化をするにあたり足りない情報や必要な情報など、コメントいただければ幸いです。
祝祭日のリスト(セル範囲）には「祭日」という名前をつけてください。
(日付データの範囲のみです。
 タイトルによくある「祝祭日」とか言う様な文字データ部分は含めないように。
 ただし、後日祝日を追加できるように、未入力セルを多めに含めるのは差支えありません）

＞A 40人
文字データは処理の邪魔なので、
「人」と言う文字データは入れないでください。
セルの書式で、そう見えるようにしてください。

＞Aさん　　15日　
出勤日数の「日」も上と同様、セルの書式でそう見せてください。
(実体は15のみとする）

> 　　A　　     B　　　　C　・ AH　　AI　　AJ
> 1　2025/3/1　　　　 　 A  ・
> 2　名　   出勤日数　　1日 ・31日   A    40人
> 3　Aさん　　15日　　　　　・〇     B　　42人
> 4　Bさん　　14日　　　　　・　　   C    45人
１日がC2セルなら、31日はAG2となるハズなのですが、実態はどうなっていますか？
付随する懸念ですが、「A   40人」のセル位置は「AI2、AJ2」で正しいですか？

>出勤扱いになる数字（１〜９、有給休暇の種類を意味する）
これは、厳密に言うと数値ですね。
(エクセルでは、数字は文字の一種と扱われます→Count関数ではカウントできない）

１．今までのシフト表を「原本」と云うシート名にしてください。
２．新規シートを一枚挿入して、シート名を「実行後」としてください。
３．その「実行後」シートの「シート見出し」を右クリックして、「コードの表示(V)」を選ぶ。
    するとVBE画面が出ますので、画面中央の白いエリアに後記マクロコードを貼り付けてください。
　　　※見た目は「標準モジュール」と同じですが、シートモジュールです
　　　　(これ重要：間違っても「標準モジュール」を追加して、そっちに貼り付けないようにしてください）

以上で準備完了です。

原本シートの希望データが揃ったら、上記マクロの「Main」を実行してください。
結果は、「実行後」シートに出ます。
採用しなかった「○」を完全に消すと「非出勤を表すブランク」と区別がつかず、
その後の作業がやりにくくなるので、「可」に変えてあります。
完全に問題が解消した後で「可」を空白に変換してください。(手作業）

※実データサンプルがないので、このマクロでどんな結果になるのか、
　現状こちらでは分かりません。簡単に修正できるレベルになっていればいいのですが・・

Private lastRow As Long, maxStaffs As Long, maxDays As Long
Private holdys As Range, LimitEachDay, msg1, msg2, App As Application

Sub Main()
    initialize
    App.ScreenUpdating = False
        データ転記      '事前処理
        単純割り振り    '単純割り振り
        列平準化        'A,B,Cパターン列平準化
        連続4回避       '連続4回避
        連続4残チェック '連続4残チェック（回避漏れの週をチェック）
        最終チェック    '出勤可能日にズレが無いかチェック
    App.ScreenUpdating = True
    
    If msg1 & msg2 <> "" Then
        MsgBox msg1 & msg2
    Else
        MsgBox "完了"
    End If
End Sub

Private Sub initialize()
    Set App = Application
    msg1 = ""
    msg2 = ""
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    maxStaffs = lastRow - 2
    maxDays = Day(App.EoMonth(Range("A1"), 0))
    Set holdys = App.Range("祭日")
    LimitEachDay = App.XLookup(Range("C1:AG1"), Range("AH2:AH4"), Range("AI2:AI4"), "")
End Sub

Private Sub データ転記() 'オリジナルシートを温存する()
    Me.UsedRange.Clear
    
    With Sheets("原本")
        '念のため、原本シートの「漢数字の〇」を「記号の○」に変換
        Intersect(.UsedRange, .Columns("C:AG")).Replace "〇", "○", xlWhole
        .UsedRange.Copy
    End With
    
    Range("A1").PasteSpecial xlPasteValuesAndNumberFormats, xlNone, False, False
    
    Range("AL2").Value = "4連続以上"
    Range("AM2").Formula2R1C1 = "={""確定数"",""有給"",""可能残"",""出勤日数""}"
    
    '「○」を「可」に変更
    Intersect(Me.UsedRange, Columns("C:AG")).Replace "○", "可", xlWhole
    
    '日付シリアル値を２行目に入力
    Range("A1").Copy Range("C2")
    
    With Range("C2")
        .AutoFill Destination:=.Resize(1, maxDays), Type:=xlFillDefault
    End With
    
    Range("C2:AG2").NumberFormatLocal = "d"
    Range("C2").Resize(maxStaffs + 6, 31).HorizontalAlignment = xlCenter
    
    With Cells(maxStaffs + 4, "C").Resize(1, maxDays)
        .Formula = _
        "=IF(NETWORKDAYS(C$2,C$2,祭日),XLOOKUP(C$1,$AH$2:$AH$4,$AI$2:$AI$4),"""")"
        .Value = .Value
    End With

    Dim 勤務可能, CL
    msg1 = ""
    For CL = 3 To maxDays + 2
        勤務可能 = App.CountIf(Cells(3, CL).Resize(maxStaffs), "可")
        
        If 勤務可能 < Cells(maxStaffs + 4, CL) Then
            msg1 = msg1 & "," & CL - 2 & vbCrLf
        End If
    Next CL
    
    If msg1 <> "" Then
        MsgBox "以下は、○不足の日です。" _
        & vbCrLf & msg1 & vbCrLf & "処理を中止します。"
        End
    End If
End Sub

Private Sub 単純割り振り()  '勤務日数だけ合わせるのみ
    Dim RW, CL, orderAry, Limit
    
    For RW = 3 To maxStaffs + 2
        orderAry = getRndAry(maxDays) '乱数配列を取得する（２次元→maxDays x 1）
        
        '当人の所要○数を算出
        Limit = Cells(RW, "B") - App.Count(Cells(RW, "C").Resize(1, maxDays))
        
        For CL = 3 To maxDays + 2
            If Cells(RW, orderAry(CL - 2, 1) + 2) = "可" Then
                Cells(RW, orderAry(CL - 2, 1) + 2) = "○"
                Limit = Limit - 1
                If Limit = 0 Then
                    Exit For
                End If
            End If
        Next CL
        
        If Limit > 0 Then
            msg1 = msg1 & Cells(RW, "A") & _
            "さんは、〇の数が絶対的に不足しています。" & vbCrLf
        End If
    Next RW
    
    DisplayResult False '中間状況を表示
End Sub

Private Sub 列平準化()   'A,B,C列の平準化
    Dim i, k, rRank As Range, MinCL As Long, maxCL As Long
    Dim kFromBack As Long, CL, TooLittle, RW
    Dim rd
   
    rd = getRndAry(maxDays) '入れ替え調整用の乱数を埋める
    Cells(maxStaffs + 9, "C").Resize(1, maxDays) = App.Transpose(rd)
    Cells(maxStaffs + 10, "C").Resize(1, maxDays).FormulaR1C1 = _
    "=N(R[-4]C)*1000000-N(R[-3]C)*1000+R[-1]C"
    
    Set rRank = Cells(maxStaffs + 11, "C").Resize(1, maxDays)
    Cells(maxStaffs + 11, "C").Formula2 = _
    "=RANK(" & rRank.Offset(-1).Address & "," & rRank.Offset(-1).Address & ",1)"
    
    For k = 1 To 100 'とりあえず100回繰り返す
        If Val(Cells(maxStaffs + 6, App.Match(maxDays, rRank, 0) + 2)) - _
            Val(Cells(maxStaffs + 6, App.Match(1, rRank, 0) + 2)) < 2 Then
            Stop
            Exit For
        Else
            For i = 1 To maxDays - 1
                MinCL = App.Match(i, rRank, 0) + 2
                If Cells(maxStaffs + 7, MinCL) <> "" Then
                    If Cells(maxStaffs + 7, MinCL) > 0 Then '可能枠あり
                        
                        For kFromBack = maxDays To i + 3 Step -1
                            maxCL = App.Match(kFromBack, rRank, 0) + 2
                            
                            For RW = 3 To maxStaffs + 2
                                If Cells(RW, MinCL) = "可" Then
                                    '当該行に○があれば入れ替え
                                    If Cells(RW, maxCL) = "○" Then
                                        Cells(RW, MinCL) = "○"
                                        Cells(RW, maxCL) = "可"
                                        GoTo tryNextSet
                                    End If
                                End If
                            Next RW
                            
                        Next kFromBack
                    End If
                End If
            Next i
tryNextSet:
        End If
    Next k

    DisplayResult True
End Sub

Private Function series4(RW) As String '1行の4連続勤務の存在チェック
    Dim COL, Cnt, Msg
        Cnt = 0
        
        For COL = 3 To maxDays + 3 '1列余分にセットする
            If Cells(RW, COL) = "○" Then
                Cnt = Cnt + 1
            Else
                If Cnt >= 4 Then
                    Msg = Msg & "," & COL - Cnt & "-" & COL - 1
                End If
                Cnt = 0
            End If
        Next COL
        
        If Msg <> "" Then
            series4 = Msg
        End If
End Function

Private Sub 連続4回避()  '4連続勤務回避処理
    Dim RW, COL, Msg, Cnt, i, Detail, ckCL, colDetail, Cont4, isFive
    
    For RW = 3 To maxStaffs + 2
        Cont4 = series4(RW)
        
        If Cont4 <> "" Then
            'Cells(RW, "AL") = Cont4
            Detail = Split(Cont4, ",") ',12-15,26-30
            
            For COL = 1 To UBound(Detail)
                colDetail = Split(Detail(COL), "-") '(1)12-15,(2)26-30
                
                isFive = IIf(colDetail(1) - colDetail(0) = 4, 1, 0)
                
                '12-15、27-29(5日連続は頭尾は除く）
                For i = colDetail(0) + isFive To colDetail(1) - isFive
                    If Exchage(RW, i) = "Done" Then
                        Exit For
                    End If
                Next i
            Next COL
        End If
        
    Next RW
End Sub

Private Sub 連続4残チェック()  '全行について4連続勤務書き出し
    Dim RW, Msg
    
    Cells(3, "AL").Resize(maxStaffs).ClearContents
    
    For RW = 3 To maxStaffs + 2
        Msg = series4(RW)
        
        If Msg <> "" Then
            Cells(RW, "AL") = Msg
        End If
    Next RW
End Sub

Private Function Exchage(自r, 自c) '可と○を入れ替え
    Dim i, k, 相手R

    For i = 3 To maxStaffs + 2
        
        If i <> 自r And Cells(i, 自c) = "可" Then '自r,相手R
            相手R = i
            For k = 3 To maxDays + 2
                If k <> 自c And Cells(自r, k) = "可" And Cells(相手R, k) = "○" Then
                    Cells(自r, 自c) = "可" 'テストのため仮変更(○→可）
                    Cells(相手R, 自c) = "○" 'テストのため仮変更
                    
                    If isAvailableDay(相手R, 自c) And isAvailableDay(自r, k) Then
                        Cells(自r, k) = "○"
                        Cells(相手R, k) = "可"
                        
                        Exchage = "Done"
                        Exit Function
                    Else  '仮変更をキャンセル
                        Cells(自r, 自c) = "○"
                        Cells(相手R, 自c) = "可"
                    End If
                End If
            Next
        End If
    Next i
End Function

Private Sub DisplayResult(All As Boolean) '結果表示
    If Not All Then
    With Cells(maxStaffs + 4, "B")
        .Resize(8, 1).ClearContents
        .Formula2 = _
        "={""所要○数"";""実○数"";""差異"";""可残数"";" & _
                """過少列"";""乱数"";""合成"";""RANK""}"
    Dim tmp
        tmp = .Resize(8, 1).Value
        .Resize(8, 1).Value = tmp
    End With
    
    With Cells(maxStaffs + 5, "C").Resize(1, maxDays)
        .FormulaR1C1 = "=IF(R[-1]C="""","""",COUNTIF(R3C:R[-3]C,""○""))"
    End With
    
    With Cells(maxStaffs + 6, "C").Resize(1, maxDays)
        .FormulaR1C1 = "=IF(R[-1]C="""","""",N(R[-1]C)-N(R[-2]C))"
    End With
    
    With Cells(maxStaffs + 7, "C").Resize(1, maxDays)
        .FormulaR1C1 = "=IF(R[-1]C="""","""",COUNTIF(R[-85]C:R[-5]C,""可""))"
    End With
    
    Else '最終結果表示
        '数式入力(出勤可能日数算出/各人）
        With Range("AM3").Resize(maxStaffs)
            .Formula2R1C1 = "=COUNTIF(RC[-36]:RC[-6],{""○"","">0"",""可""})"
        End With
        
        Range("AP3").Resize(maxStaffs).FormulaR1C1 = "=SUM(RC[-3]:RC[-2])"
        
        Rows(maxStaffs + 9).Resize(3).ClearContents
    End If
End Sub

Private Function isAvailableDay(RW, COL) 'ある日の前後○連続性をチェック
    Dim i, Cnt
    
    For i = COL - 1 To 3 Step -1
        If Cells(RW, i) = "○" Then
            Cnt = Cnt + 1
        Else
            Exit For
        End If
    Next
    
    For i = COL + 1 To 33
        If Cells(RW, i) = "○" Then
            Cnt = Cnt + 1
        Else
            Exit For
        End If
    Next
    
    isAvailableDay = Cnt < 3
End Function

Private Function getRndAry(n As Long) '乱数生成
    Dim i As Long, myRnd() As Double, randomOrder, Check
    Randomize
    ReDim myRnd(1 To n)
    
    Do
        For i = 1 To n
            myRnd(i) = rnd     '乱数を格納
        Next i
        
        Check = App.Frequency(App.Frequency(myRnd, myRnd), Array(1)) '重複の有無を確認
    Loop While Check(2, 1) <> 0 '重複が無くなるまで
    
    randomOrder = App.Small(myRnd, App.Sequence(n)) '乱数を昇順に並べ替え
    getRndAry = App.Match(randomOrder, myRnd, 0) '乱数の順位配列
End Function

Sub 最終チェック()
    initialize
    
    Dim i, k
    
    With Sheets("原本") '出勤可能日と決定出勤日の齟齬
        For i = 3 To maxStaffs + 2
            For k = 3 To maxDays + 2
                If Cells(i, k) <> .Cells(i, k) Then
                    Select Case True
                        Case Cells(i, k) = "○"
                            msg2 = msg2 & vbCrLf & "シート間に齟齬：" _
                            & Cells(i, k).Address(0, 0) & "セル"
                            Cells(i, k).Interior.Color = vbRed
                            Cells(i, k).Font.Color = vbYellow
                        Case IsEmpty(Cells(i, k)) And .Cells(i, k) = "○"
                            Cells(i, k).Interior.Color = vbYellow
                    End Select
                End If
            Next k
        Next i
    End With
    
    For i = 3 To maxStaffs + 2 '出勤日数と希望日数の齟齬
        If Cells(i, "B") <> Cells(i, "AP") Then
            Cells(i, "B").Interior.Color = vbRed
            Cells(i, "B").Font.Color = vbYellow
        End If
    Next i
    
    Dim RW, COL, Detail, colDetail
    For RW = 3 To maxStaffs + 2  '4日以上連続に色付け
        
        If Cells(RW, "AL") <> "" Then
            Detail = Split(Cells(RW, "AL"), ",") ',12-15,26-30
            
            For COL = 1 To UBound(Detail)
                colDetail = Split(Detail(COL), "-") '(1)12-15,(2)26-30
                
                For i = colDetail(0) To colDetail(1)
                    Cells(RW, i).Interior.Color = vbBlue
                    Cells(RW, i).Font.Color = vbWhite
                Next i
            Next COL
        End If
        
    Next RW
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

＞（マウスに丸いグルグルが表示されます
そちらで使ったデータがどんなものか分からないと、
当方でトラブルを再現するのはむずかしいです。

なので、そちらの原本シートのAL1セルに下式を入れ、
出てきた結果1列(AL1:AL83）をコピーして、この掲示板に貼り付けて貰えませんか？

=BYROW(B1:AI83,LAMBDA(r,TEXTJOIN(",",FALSE,r)))

結果例:
,A,B,A,C,B,B,A,A,B,A,C,B,B,A,A,B,A,C,B,C,A,A,B,A,C,B,B,A,A,B,A,,
出勤日数,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,11,21,22,23,24,25,26,27,28,29,30,31,A,40
13,,,○,1,○,○,○,,,○,,1,○,○,,,○,○,○,○,○,,,,○,○,○,○,,,,B,52
： ： ： ：： ：
83行目まで