『出勤のシフト表の作り方』（れもん）
Excelで出勤シフトを自動で作りたいです。「出勤」か「休」のみの表示です。
月の出勤日数は人によって違いますがそれぞれの日数に合わせて。また、５連勤にならずに、週に２日は休みが入るように、また１日の合計出勤日数は月内でできるだけ均等化するように、可能ですか？
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
はい、可能です。
まずはデータがどこにどのような形式で保存されているかを提示してください。 私たちは貴方の頭の中身を見ることはできませんので。
事前に謎なところを指摘しておきます。
> ５連勤にならずに、週に２日は休みが入るように →4連勤までが許容範囲なら、休みは週に3日以上なはずです。
> １日の合計出勤日数は月内でできるだけ均等化するように →合計出勤人数、の誤りですか？ （Asa） 2026/04/02(木) 22:12:43
ん？何か勘違いをしていました 4連勤で週2日休みは可能でしたね （Asa） 2026/04/02(木) 22:16:56
？ 何も作っていないとは？ 例えば「月の出勤日数は人によって違う」のですよね？ それは貴方の頭の中にしかないということでしょうか？ （Asa） 2026/04/02(木) 22:41:28
なぜ月の出勤日数の話をしているのに週の出勤日数の話をしてくるのかよくわかりませんが。
こういったケースは焼きなましと相場が決まっています。 VBAで書くのが面倒すぎるので実装はAIに任せましたが、アルゴリズム自体は基本的なものです。
Option Explicit
' --- 設定用構造体 ---
Private Type Config
StaffCount As Long
DaysCount As Long
WeeksCount As Long
IterMax As Long
StartTemp As Double
CoolingRate As Double
PenaltyWeight As Double
End Type
Sub GenerateMonthlyShiftWithConsecutiveOff()
Dim cfg As Config
Dim i As Long, w As Long, iter As Long
' 1. 基本設定
With cfg
.StaffCount = 8
.DaysCount = Day(DateSerial(Year(Date), Month(Date) + 1, 0))
.WeeksCount = Application.WorksheetFunction.RoundUp(.DaysCount / 7, 0)
.IterMax = 150000
.StartTemp = 15#
.CoolingRate = 0.9999
.PenaltyWeight = 20#
End With
' 各スタッフの「週あたりの」勤務日数
Dim weeklyWorkDays As Variant
weeklyWorkDays = Array(0, 5, 5, 5, 5, 5, 4, 4, 3)
' 2. 1週間用パターンの事前生成
Dim weeklyPatterns() As Collection
ReDim weeklyPatterns(1 To cfg.StaffCount)
For i = 1 To cfg.StaffCount
Set weeklyPatterns(i) = EnumeratePatterns(7, weeklyWorkDays(i))
Next
' 3. 初期解の生成
' current(スタッフ, 週) = 7日間の配列
Dim current() As Variant: ReDim current(1 To cfg.StaffCount, 1 To cfg.WeeksCount)
Dim dailyCount() As Long: ReDim dailyCount(0 To cfg.DaysCount - 1)
Randomize
For i = 1 To cfg.StaffCount
For w = 1 To cfg.WeeksCount
current(i, w) = weeklyPatterns(i)(Int(Rnd() * weeklyPatterns(i).Count) + 1)
AddDailyCount dailyCount, current(i, w), w, cfg.DaysCount
Next
Next
' ターゲット（1日の平均出勤人数）
Dim totalWork As Long: For i = 1 To cfg.StaffCount: totalWork = totalWork + (weeklyWorkDays(i) * cfg.WeeksCount): Next
Dim targetPerDay As Double: targetPerDay = totalWork / cfg.DaysCount
' 初期スコア計算
Dim currentScore As Double: currentScore = CalculateTotalScore(dailyCount, current, targetPerDay, cfg)
Dim bestScore As Double: bestScore = currentScore
Dim best() As Variant: best = current
' 4. 焼きなましループ
Dim T As Double: T = cfg.StartTemp
Dim targetS As Long, targetW As Long
Dim oldP As Variant, newP As Variant, dE As Double
Application.StatusBar = "最適化計算中... (連休優先モード)"
For iter = 1 To cfg.IterMax
' 近傍選択：ランダムな1人の特定の1週間を入れ替え
targetS = Int(Rnd() * cfg.StaffCount) + 1
targetW = Int(Rnd() * cfg.WeeksCount) + 1
oldP = current(targetS, targetW)
newP = weeklyPatterns(targetS)(Int(Rnd() * weeklyPatterns(targetS).Count) + 1)
' 差分スコア計算（人数平準化 ＋ 連休ペナルティ）
dE = CalculateWeeklyDiffScore(dailyCount, current, targetS, targetW, oldP, newP, targetPerDay, cfg)
' 遷移判定
If dE <= 0 Or Rnd() < Exp(-dE / T) Then
UpdateDailyCount dailyCount, oldP, newP, targetW, cfg.DaysCount
current(targetS, targetW) = newP
currentScore = currentScore + dE
If currentScore < bestScore Then
bestScore = currentScore
best = current
If bestScore < 0.0001 Then Exit For
End If
End If
T = T * cfg.CoolingRate
If iter Mod 10000 = 0 Then
DoEvents
Application.StatusBar = "計算中: " & Format(iter / cfg.IterMax, "0%") & " Score: " & Format(currentScore, "0.00")
End If
Next
' 5. 結果出力
OutputMonthly best, cfg, dailyCount
Application.StatusBar = False
MsgBox "完了" & vbCrLf & "最終スコア: " & Format(bestScore, "0.00")
End Sub
' --- スコア計算ロジック ---
Function CalculateTotalScore(counts() As Long, current() As Variant, target As Double, cfg As Config) As Double
Dim d As Long, i As Long, s As Double
' 人数平準化
For d = 0 To cfg.DaysCount - 1: s = s + (counts(d) - target) ^ 2: Next
' 連休ペナルティ
Dim p As Double: For i = 1 To cfg.StaffCount: p = p + CalculateIndividualPenalty(current, i, cfg): Next
CalculateTotalScore = s + (p * cfg.PenaltyWeight)
End Function
Function CalculateWeeklyDiffScore(counts() As Long, current() As Variant, targetS As Long, targetW As Long, _
oldP As Variant, newP As Variant, target As Double, cfg As Config) As Double
Dim d As Long, gDay As Long, diff As Double
Dim oldC As Long, newC As Long
' 人数平準化の差分
For d = 0 To 6
gDay = (targetW - 1) * 7 + d
If gDay < cfg.DaysCount Then
oldC = counts(gDay)
newC = counts(gDay) - oldP(d) + newP(d)
diff = diff + (newC - target) ^ 2 - (oldC - target) ^ 2
End If
Next
' 連休ペナルティの差分
Dim oldPnl As Double, newPnl As Double
oldPnl = CalculateIndividualPenalty(current, targetS, cfg)
Dim tempP As Variant: tempP = current(targetS, targetW)
current(targetS, targetW) = newP
newPnl = CalculateIndividualPenalty(current, targetS, cfg)
current(targetS, targetW) = tempP ' 戻す
diff = diff + (newPnl - oldPnl) * cfg.PenaltyWeight
CalculateWeeklyDiffScore = diff
End Function
' 単発の休み（前後に休みがない休み）にペナルティを与える
Function CalculateIndividualPenalty(current() As Variant, sIdx As Long, cfg As Config) As Double
Dim full() As Long: ReDim full(0 To cfg.DaysCount - 1)
Dim w As Long, d As Long, gDay As Long, p As Double
' 1ヶ月分展開
For w = 1 To cfg.WeeksCount
For d = 0 To 6
gDay = (w - 1) * 7 + d
If gDay < cfg.DaysCount Then full(gDay) = current(sIdx, w)(d)
Next
Next
' 孤立した0(休み)をカウント
For d = 0 To cfg.DaysCount - 1
If full(d) = 0 Then
Dim isolated As Boolean: isolated = True
' 左隣が休みなら孤立していない
If d > 0 Then If full(d - 1) = 0 Then isolated = False
' 右隣が休みなら孤立していない
If d < cfg.DaysCount - 1 Then If full(d + 1) = 0 Then isolated = False
If isolated Then p = p + 1
End If
Next
CalculateIndividualPenalty = p
End Function
' --- パターン生成 (7日間) ---
Function EnumeratePatterns(days As Long, work As Variant) As Collection
Dim col As New Collection
Dim arr() As Long: ReDim arr(0 To days - 1)
Call DFS_Recursive(col, arr, 0, CInt(work), days)
Set EnumeratePatterns = col
End Function
Sub DFS_Recursive(col As Collection, arr() As Long, dayIdx As Long, remainWork As Long, totalDays As Long)
If remainWork < 0 Or remainWork > (totalDays - dayIdx) Then Exit Sub
If dayIdx = totalDays Then
If remainWork = 0 Then col.Add arr
Exit Sub
End If
arr(dayIdx) = 1: Call DFS_Recursive(col, arr, dayIdx + 1, remainWork - 1, totalDays)
arr(dayIdx) = 0: Call DFS_Recursive(col, arr, dayIdx + 1, remainWork, totalDays)
End Sub
' --- ヘルパー関数 ---
Sub UpdateDailyCount(counts() As Long, oldP As Variant, newP As Variant, weekIdx As Long, maxDays As Long)
Dim d As Long, gDay As Long
For d = 0 To 6
gDay = (weekIdx - 1) * 7 + d
If gDay < maxDays Then counts(gDay) = counts(gDay) - oldP(d) + newP(d)
Next
End Sub
Sub AddDailyCount(counts() As Long, p As Variant, weekIdx As Long, maxDays As Long)
Dim d As Long, gDay As Long
For d = 0 To 6
gDay = (weekIdx - 1) * 7 + d
If gDay < maxDays Then counts(gDay) = counts(gDay) + p(d)
Next
End Sub
' --- 出力 ---
Sub OutputMonthly(best() As Variant, cfg As Config, finalCounts() As Long)
Dim i As Long, w As Long, d As Long, gDay As Long
Dim data() As Variant: ReDim data(1 To cfg.StaffCount + 2, 1 To cfg.DaysCount + 1)
' ヘッダーと出勤人数行
data(cfg.StaffCount + 2, 1) = "出勤人数"
For gDay = 1 To cfg.DaysCount
data(1, gDay + 1) = gDay
data(cfg.StaffCount + 2, gDay + 1) = finalCounts(gDay - 1)
Next
' 各スタッフ
For i = 1 To cfg.StaffCount
data(i + 1, 1) = "Staff " & i
For w = 1 To cfg.WeeksCount
For d = 0 To 6
gDay = (w - 1) * 7 + d
If gDay < cfg.DaysCount Then
data(i + 1, gDay + 2) = IIf(best(i, w)(d) = 1, "出勤", "休")
End If
Next
Next
Next
With ActiveSheet
.Cells.Clear
.Range("A1").Resize(cfg.StaffCount + 2, cfg.DaysCount + 1).Value = data
.Columns.AutoFit
End With
End Sub
（Asa） 2026/04/02(木) 23:55:05
週ごとに生成した結果、週を跨いでの6連勤が発生していたので修正です。
Option Explicit
' --- 設定用構造体 ---
Private Type Config
StaffCount As Long
DaysCount As Long
WeeksCount As Long
IterMax As Long
StartTemp As Double
CoolingRate As Double
WeightSingleOff As Double
WeightOverWork As Double
End Type
Sub GenerateMonthlyShift()
Dim cfg As Config
Dim i As Long, w As Long, iter As Long
' 1. 基本設定
With cfg
.StaffCount = 8
.DaysCount = Day(DateSerial(Year(Date), Month(Date) + 2, 0))
.WeeksCount = Application.WorksheetFunction.RoundUp(.DaysCount / 7, 0)
.IterMax = 300000
.StartTemp = 20#
.CoolingRate = 0.99995
.WeightSingleOff = 20#
.WeightOverWork = 2000#
End With
' 各スタッフの「週あたりの」勤務日数
Dim weeklyWorkDays As Variant
weeklyWorkDays = Array(0, 5, 5, 5, 5, 5, 4, 4, 3)
' 2. パターン生成（7日間）
Dim weeklyPatterns() As Collection: ReDim weeklyPatterns(1 To cfg.StaffCount)
For i = 1 To cfg.StaffCount
Set weeklyPatterns(i) = EnumeratePatterns(7, weeklyWorkDays(i))
Next
' 3. 初期解の生成
Dim current() As Variant: ReDim current(1 To cfg.StaffCount, 1 To cfg.WeeksCount)
Dim dailyCount() As Long: ReDim dailyCount(0 To cfg.DaysCount - 1)
Randomize
For i = 1 To cfg.StaffCount
For w = 1 To cfg.WeeksCount
current(i, w) = weeklyPatterns(i)(Int(Rnd() * weeklyPatterns(i).Count) + 1)
AddDailyCount dailyCount, current(i, w), w, cfg.DaysCount
Next
Next
' ターゲット人数
Dim totalWork As Long: For i = 1 To cfg.StaffCount: totalWork = totalWork + (weeklyWorkDays(i) * cfg.WeeksCount): Next
Dim targetPerDay As Double: targetPerDay = totalWork / cfg.DaysCount
' スコア計算
Dim currentScore As Double: currentScore = CalculateTotalScore(dailyCount, current, targetPerDay, cfg)
Dim bestScore As Double: bestScore = currentScore
Dim best() As Variant: best = current
' 4. 焼きなましループ
Dim T As Double: T = cfg.StartTemp
Dim targetS As Long, targetW As Long
Dim oldP As Variant, newP As Variant, dE As Double
For iter = 1 To cfg.IterMax
targetS = Int(Rnd() * cfg.StaffCount) + 1
targetW = Int(Rnd() * cfg.WeeksCount) + 1
oldP = current(targetS, targetW)
newP = weeklyPatterns(targetS)(Int(Rnd() * weeklyPatterns(targetS).Count) + 1)
' 差分計算
dE = CalculateWeeklyDiffScore(dailyCount, current, targetS, targetW, oldP, newP, targetPerDay, cfg)
If dE <= 0 Or Rnd() < Exp(-dE / T) Then
UpdateDailyCount dailyCount, oldP, newP, targetW, cfg.DaysCount
current(targetS, targetW) = newP
currentScore = currentScore + dE
If currentScore < bestScore Then
bestScore = currentScore
best = current
If bestScore < 0.0001 Then Exit For
End If
End If
T = T * cfg.CoolingRate
If iter Mod 10000 = 0 Then
Application.StatusBar = "計算中: " & Format(iter / cfg.IterMax, "0%") & " Score: " & Format(currentScore, "0.0")
DoEvents
End If
Next
' 5. 出力
OutputMonthly best, cfg, dailyCount
Application.StatusBar = False
MsgBox "完了" & vbCrLf & "最終スコア: " & Format(bestScore, "0.0")
End Sub
' --- スコア計算ロジック（差分計算） ---
Function CalculateWeeklyDiffScore(counts() As Long, current() As Variant, targetS As Long, targetW As Long, _
oldP As Variant, newP As Variant, target As Double, cfg As Config) As Double
Dim d As Long, gDay As Long, diff As Double
Dim oldC As Long, newC As Long
' A. 人数平準化の差分
For d = 0 To 6
gDay = (targetW - 1) * 7 + d
If gDay < cfg.DaysCount Then
oldC = counts(gDay)
newC = counts(gDay) - oldP(d) + newP(d)
diff = diff + (newC - target) ^ 2 - (oldC - target) ^ 2
End If
Next
' B. 個人の制約（連休・6連勤）の差分
Dim oldPnl As Double, newPnl As Double
oldPnl = CalculateIndividualPenalty(current, targetS, cfg)
Dim tempP As Variant: tempP = current(targetS, targetW)
current(targetS, targetW) = newP
newPnl = CalculateIndividualPenalty(current, targetS, cfg)
current(targetS, targetW) = tempP ' 元に戻す
diff = diff + (newPnl - oldPnl) ' 各項目の重みはCalculateIndividualPenalty内で計算済み
CalculateWeeklyDiffScore = diff
End Function
Function CalculateTotalScore(counts() As Long, current() As Variant, target As Double, cfg As Config) As Double
Dim d As Long, i As Long, s As Double
For d = 0 To cfg.DaysCount - 1: s = s + (counts(d) - target) ^ 2: Next
For i = 1 To cfg.StaffCount: s = s + CalculateIndividualPenalty(current, i, cfg): Next
CalculateTotalScore = s
End Function
' 個人のペナルティ計算（重み付け込み）
Function CalculateIndividualPenalty(current() As Variant, sIdx As Long, cfg As Config) As Double
Dim full() As Long: ReDim full(0 To cfg.DaysCount - 1)
Dim w As Long, d As Long, gDay As Long
Dim scoreSingleOff As Double, scoreOverWork As Double
' 1ヶ月分に展開
For w = 1 To cfg.WeeksCount
For d = 0 To 6
gDay = (w - 1) * 7 + d
If gDay < cfg.DaysCount Then full(gDay) = current(sIdx, w)(d)
Next
Next
Dim consecutiveWork As Long: consecutiveWork = 0
For d = 0 To cfg.DaysCount - 1
' 1. 単発休みの判定
If full(d) = 0 Then
Dim isolated As Boolean: isolated = True
If d > 0 Then If full(d - 1) = 0 Then isolated = False
If d < cfg.DaysCount - 1 Then If full(d + 1) = 0 Then isolated = False
If isolated Then scoreSingleOff = scoreSingleOff + cfg.WeightSingleOff
consecutiveWork = 0 ' 休みが入ったのでリセット
Else
' 2. 6連勤以上の判定
consecutiveWork = consecutiveWork + 1
If consecutiveWork >= 6 Then
' 6日目以降、1日ごとに強烈なペナルティを加算
scoreOverWork = scoreOverWork + cfg.WeightOverWork
End If
End If
Next
CalculateIndividualPenalty = scoreSingleOff + scoreOverWork
End Function
' --- 以下、基本ロジック（パターン生成等） ---
Function EnumeratePatterns(days As Long, work As Variant) As Collection
Dim col As New Collection: Dim arr() As Long: ReDim arr(0 To days - 1)
Call DFS_Recursive(col, arr, 0, CInt(work), days)
Set EnumeratePatterns = col
End Function
Sub DFS_Recursive(col As Collection, arr() As Long, idx As Long, remW As Long, total As Long)
If remW < 0 Or remW > (total - idx) Then Exit Sub
If idx = total Then: If remW = 0 Then col.Add arr: Exit Sub
arr(idx) = 1: Call DFS_Recursive(col, arr, idx + 1, remW - 1, total)
arr(idx) = 0: Call DFS_Recursive(col, arr, idx + 1, remW, total)
End Sub
Sub UpdateDailyCount(counts() As Long, oldP As Variant, newP As Variant, wIdx As Long, maxD As Long)
Dim d As Long, g As Long
For d = 0 To 6: g = (wIdx - 1) * 7 + d: If g < maxD Then counts(g) = counts(g) - oldP(d) + newP(d)
Next
End Sub
Sub AddDailyCount(counts() As Long, p As Variant, wIdx As Long, maxD As Long)
Dim d As Long, g As Long
For d = 0 To 6: g = (wIdx - 1) * 7 + d: If g < maxD Then counts(g) = counts(g) + p(d)
Next
End Sub
Sub OutputMonthly(best() As Variant, cfg As Config, finalCounts() As Long)
Dim i As Long, w As Long, d As Long, g As Long
Dim data() As Variant: ReDim data(1 To cfg.StaffCount + 2, 1 To cfg.DaysCount + 1)
For g = 1 To cfg.DaysCount: data(1, g + 1) = g: data(cfg.StaffCount + 2, g + 1) = finalCounts(g - 1): Next
data(cfg.StaffCount + 2, 1) = "出勤合計"
For i = 1 To cfg.StaffCount
data(i + 1, 1) = "Staff " & i
For w = 1 To cfg.WeeksCount
For d = 0 To 6
g = (w - 1) * 7 + d
If g < cfg.DaysCount Then data(i + 1, g + 2) = IIf(best(i, w)(d) = 1, "出勤", "休")
Next
Next
Next
Application.ScreenUpdating = False
With ActiveSheet
.Cells.Clear
.Range("A1").Resize(cfg.StaffCount + 2, cfg.DaysCount + 1).Value = data
.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
（Asa） 2026/04/03(金) 00:05:19
スコアの計算に 連休の方が良い/6連勤はNG を使用し 焼きなまし法で一定の回数まで探索しているだけです。
焼きなまし法については下記のページをご参照ください。 https://algo-method.com/descriptions/oe3TjVcJgyQyPlPb
（Asa） 2026/04/03(金) 00:17:32
# 焼きなまし法（Simulated Annealing法）は私も以前こちらの掲示板の回答で使ったことがあります。 参考になりますね。
ところで、余り詳細を見ていませんけど、月ごとで決めていく方式だと、 対象月とその前月末との接続箇所で、6日以上の連続勤務のペナルティが考慮されないので、 最終案が、6日以上の連続勤務をもたらすものになってしまう可能性はないのですか？
>週5日勤務の人が6人、週4日勤務の人が1人、週3日勤務が1人です。 ですよね、コードの前提が少し違うような。
"目の子"で作ると、こんな規則的なものでもよさそうな感じです。(1が出勤を表します） このパターンを毎週繰り返します。
第一週 第二週 ⇒に以下繰り返す
週5日 Staff 1 1 1 1 1 1 1 1 1 1 1
〃 Staff 2 1 1 1 1 1 1 1 1 1 1
〃 Staff 3 1 1 1 1 1 1 1 1 1 1
〃 Staff 4 1 1 1 1 1 1 1 1 1 1
〃 Staff 5 1 1 1 1 1 1 1 1 1 1
〃 Staff 6 1 1 1 1 1 1 1 1 1 1
週4日 Staff 7 1 1 1 1 1 1 1 1
週3日 Staff 8 1 1 1 1 1 1
出勤者数計 5 5 5 5 6 6 5 5 5 5 5 6 6 5
あと、勤務者から特定の日の休暇を希望するなどと言う話がありますが、適宜、弾力的に対応してくださいｗ
（xyz） 2026/04/03(金) 06:04:42
AIで作ったものをやってみましたが、大事なことを忘れていました。
土曜と日曜だけ出勤人数を４人にすることは可能ですか。
後だしで本当に申し訳ありません。
（れもん） 2026/04/03(金) 07:28:51
xyzさん 確かに月跨ぎで6連勤になってしまう可能性はあります。 STAFF1-5,6-7が交換可能であると考えれば、そこは目視でやるしかないかなと。 他に考えられるのは月末と月初の連勤に少しペナルティを与えるイメージですかね。
れもんさん ご覧になっていただいて分かる通り結構めんどくさい内容です。無理ではないですが。 他に言ってないことはないですか？ （Asa） 2026/04/03(金) 07:52:04
かなり、めんどくさい内容ですよね。申し訳ありません。
（れもん） 2026/04/03(金) 08:46:47
申し訳ございませんが情報のキャッチボールができないので私は撤退いたします
>希望の休みをそれぞれ４～５日入れたい 最初にデータの場所や形式を聞いたのはそういったケースが存在しそうだと推測したからであり 結局後から追加するなら、やはり「データはどこにあるのか」という最初の疑問に戻ります 結果として、なぜその要望を出してきておきながらデータについての言及が全くないのか謎です
>週５日の人は祝日の休みの日数も加えたい 重複しますが、月の話をしているのか週の話をしているのかよくわかりません 何度か試してみればわかるかと思いますが、週ベースでの指定では月の出勤数にブレが生じます 加えて、大前提私のコードでは翌月のシフトとしていますが、そこについても言及がありませんので、どこまでが要望に沿っているのかもわかりません そもそも、「週5日」という指定があるのに「休みの日程を加える」という意味がわかりません 休みの日程が加減するならそもそも「週5日」ではなく「平日」と指定しているはずです
本当に私の回答を試しているのか、なぜそうなるのか多少でも考えているのか
後から要望をポンポン出して、他に必要な情報がなんなのかを全く考えられていないですよね
「焼きなまし」について少しでも理解しようとしていれば 後から要件を追加し続けると計算量が肥大化し、VBAでの実装が非現実的になっていくことはご理解いただけると思います （Asa） 2026/04/03(金) 09:53:36
https://king.mineo.jp/reports/285664 アルゴリズム考えている時間は取れないので参考になりそうなリンクを張っておきます。 他のexcel質問系へのリンクはだめだったら消してください （ちくわ） 2026/04/03(金) 10:08:43
ちくわさん、ご提示ありがとうございます。
見て勉強したいと思います。
ありがとうございました。
（れもん） 2026/04/03(金) 10:13:31
>週５日の人は祝日の休みの日数も加えたい 私も意味がわかりません。もう少し説明してください。 また、例示として、昨年の10月と11月のシフト表を提示して下さい。 （もちろん固有名詞は不要です。） 検討する人の参考になるのではないかと思います。
（xyz） 2026/04/03(金) 14:31:08
EFGHさんは週何回という勤務形態なので先月の状況により、休みの日数が変わります。それはできあがったものを見て手動調整をするしかないと思います。
それぞれが休みの希望を事前に４～５日出すので、そこは休みを確定させた上でシフト表を作りたいです。
過去のシフトはないので、先月のシフトは下記のようになっています。有給や希望の欠勤もあるので規定よりも多く休みになっている人もいますが。
StaffA 1101101011110110111010101111001
StaffB 0110110111101011100111001111011
StaffC 0110110111101011100111001111011
StaffD 1111010110101101011101011101110
StaffE 1001110111001011101100110110011
StaffF 1110011100111110011110111110001
StaffG 1100101010011101110011101100010
StaffH 0011010100111001100101110010110
このような複雑なものを自動で可能か、お聞きしたかったです。
（れもん） 2026/04/03(金) 22:58:41
こうした問題はナーススケジューリング問題などと言われており、研究の積み重ねがあるようです。 対応方針は大きく分けると2種類です。 ・最適化のためのソルバーを利用する方法です。これが採られることが多いようです。 制約条件、目的関数を定義して、それをソルバーに投げるという方式です。 Excelに備わったソルバーは独立変数が200個までという制限があるので、非力です。(30*8=240で既に限度を超えます) Excelではなく例えばPythonのような言語を利用して外部のソルバーを利用する方法があります。 ・ヒューリスティックなアルゴリズムを作って、最適化問題を自分で解くことです。 例えば、焼きなまし法や遺伝的アルゴリズムといったものはそのアルゴリズムの一例です。 VBAコードで解を求めるのは、こちらに属するでしょう。
私はどちらかというと前者に興味があるので、(Excelを前提とした)このケースには貢献できそうもありません。 こちらにはこうした問題に詳しい方もいらっしゃるので、コメントがあるかもしれません。
---------------- 提示された3月分のシフト表、拝見しました。ありがとうございます。 (2か月分連続した月のものがあれば明確になることもあったので残念です。) 参考までに、気づいた点をメモしておきます。
> ABCDさん→土日と祝日の数をお休みにする(今月だと9回) > EさんFさん→祝日は考慮せず週に5日の勤務 > Gさん→祝日は考慮せず週に4日の勤務 > Hさん→祝日は考慮せずに週に3日の勤務
ABCDさんは、ひと月の休暇数が定められているので、週によって偏りがあっても問題ないということですか? 6連続勤務禁止との関係はどうなりますか?
週に関する記述が多いですが、「週」の定義はなんでしょうか。 ・1日から始まる7日が第一週ですか? ・それとも曜日基準ですか?月初、月末の端数日の扱いはどうなりますか?前の月との関係も見るのですか?
Hさんは週3日勤務ですが、3月は16日勤務しています（5週間以上分の勤務に相当）。 これは問題ないのですか？
土日を4人勤務というのはどの程度守られているんですか? 2人の場合も6人の場合もありますが、これで問題ないのですか?
平日も4人勤務とか7人勤務とか結構ばらけてますが、これは許容範囲内なんですね?
色々な制約条件がありますが、それぞれの優先度というか重要度も大体でよいのですが示せませんか？
なお、現状はどのように作成していて、どこに問題があると考えているのでしょうか? それらを書いていただくと、回答コメントも得られやすくなるように思います。 それでは。
（xyz） 2026/04/04(土) 10:17:09
「先月のシフトは下記のようになっています。」は日付と曜日を示さないと分かりませんよ。
|[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]|[AD]|[AE]|[AF]
[1] | |3/1|3/2|3/3|3/4|3/5|3/6|3/7|3/8|3/9|3/10|3/11|3/12|3/13|3/14|3/15|3/16|3/17|3/18|3/19|3/20|3/21|3/22|3/23|3/24|3/25|3/26|3/27|3/28|3/29|3/30|3/31
[2] | |日 |月 |火 |水 |木 |金 |土 |日 |月 |火 |水 |木 |金 |土 |日 |月 |火 |水 |木 |金 |土 |日 |月 |火 |水 |木 |金 |土 |日 |月 |火
[3] |スタッフA| 1| 1| 0| 1| 1| 0| 1| 0| 1| 1| 1| 1| 0| 1| 1| 0| 1| 1| 1| 0| 1| 0| 1| 0| 1| 1| 1| 1| 0| 0| 1
[4] |スタッフB| 0| 1| 1| 0| 1| 1| 0| 1| 1| 1| 1| 0| 1| 0| 1| 1| 1| 0| 0| 1| 1| 1| 0| 0| 1| 1| 1| 1| 0| 1| 1
[5] |スタッフC| 0| 1| 1| 0| 1| 1| 0| 1| 1| 1| 1| 0| 1| 0| 1| 1| 1| 0| 0| 1| 1| 1| 0| 0| 1| 1| 1| 1| 0| 1| 1
[6] |スタッフD| 1| 1| 1| 1| 0| 1| 0| 1| 1| 0| 1| 0| 1| 1| 0| 1| 0| 1| 1| 1| 0| 1| 0| 1| 1| 1| 0| 1| 1| 1| 0
[7] |スタッフE| 1| 0| 0| 1| 1| 1| 0| 1| 1| 1| 0| 0| 1| 0| 1| 1| 1| 0| 1| 1| 0| 0| 1| 1| 0| 1| 1| 0| 0| 1| 1
[8] |スタッフF| 1| 1| 1| 0| 0| 1| 1| 1| 0| 0| 1| 1| 1| 1| 1| 0| 0| 1| 1| 1| 1| 0| 1| 1| 1| 1| 1| 0| 0| 0| 1
[9] |スタッフG| 1| 1| 0| 0| 1| 0| 1| 0| 1| 0| 0| 1| 1| 1| 0| 1| 1| 1| 0| 0| 1| 1| 1| 0| 1| 1| 0| 0| 0| 1| 0
[10]|スタッフH| 0| 0| 1| 1| 0| 1| 0| 1| 0| 0| 1| 1| 1| 0| 0| 1| 1| 0| 0| 1| 0| 1| 1| 1| 0| 0| 1| 0| 1| 1| 0
（おてつだい） 2026/04/04(土) 10:29:45
週の定義は日曜から土曜までの１週間です。
6日連続禁止と、日曜から土曜日までの１週間の間に必ず２日の休み、これが全員の最優先の条件です。
なので、人数が多い分に関しては許容しています。５人位が一番望ましいですが。
前の月との関係も見ますが、これは手動で対応するしかないかと思っています。
４人に満たないところは外部から応援をもらっています。できるだけ４人は集まるようにしています。
現状、それぞれの希望に沿って作っているため、人数の差がでてしまっています。
すべての日で最低確保したい人数は４人です。
現状の問題は土日に人が集まらないことです。
２か月分のシフトが必要だったんですね。いまさらですが、一応のせますね。
[1] | |2/1| 2| 3| 4| 5| 6| 7| 8| 9| 10| 11| 12| 13| 14| 15| 16| 17| 18| 19| 20| 21| 22| 23| 24| 25| 26| 27| 28|
[2] | | 日| 月| 火| 水| 木| 金| 土| 日| 月| 火| 水| 木| 金| 土| 日| 月| 火| 水| 木| 金| 土| 日| 月| 火| 水| 木| 金| 土|
[3] |スタッフA| 0| 0| 1| 1| 1| 1| 1| 0| 0| 1| 0| 1| 1| 1| 1| 0| 1| 1| 1| 0| 1| 0| 0| 1| 1| 0| 1| 1|
[4] |スタッフB| 1| 0| 1| 1| 1| 0| 1| 1| 0| 0| 1| 1| 1| 0| 1| 1| 0| 1| 0| 1| 1| 0| 0| 0| 0| 1| 1| 1|
[5] |スタッフC| 1| 1| 1| 1| 0| 0| 0| 0| 1| 1| 1| 1| 0| 1| 1| 1| 0| 0| 1| 1| 0| 0| 1| 1| 1| 1| 0| 1|
[6] |スタッフD| 0| 1| 0| 1| 1| 0| 0| 1| 1| 0| 1| 0| 1| 1| 1| 1| 0| 1| 1| 0| 1| 1| 1| 0| 1| 1| 1| 0|
[7] |スタッフE| 1| 1| 0| 1| 1| 1| 0| 1| 1| 0| 0| 1| 1| 0| 0| 1| 1| 0| 1| 0| 0| 1| 1| 0| 1| 0| 1| 1|
[8] |スタッフF| 1| 1| 0| 1| 1| 0| 1| 1| 1| 1| 0| 0| 1| 1| 1| 0| 1| 1| 1| 1| 0| 0| 1| 1| 1| 0| 1| 1|
[9] |スタッフG| 0| 1| 1| 0| 0| 1| 1| 1| 0| 1| 1| 0| 0| 0| 0| 0| 1| 1| 0| 1| 1| 1| 0| 1| 1| 1| 0| 0|
[10]|スタッフH| 1| 1| 0| 0| 1| 0| 1| 0| 1| 1| 1| 0| 0| 0| 0| 1| 1| 0| 0| 1| 0| 0| 1| 1| 0| 0| 0| 0|
どうもありがとうございました。
（れもん） 2026/04/05(日) 22:23:58
少々お聞きします。
１．「それぞれが 休みの希望を事前に４～５日出す」との事ですが、 この休みは、本来与えるべき休みの枠内ですね？
一方、有給や希望の欠勤と言うのは、枠外ですね？
２．「枠内希望の休み」と「枠外希望の休み」はシフト予定表上、どう区別できるようになっているのですか？ 「休、空白、0、有、欠」なんかが頭をよぎるのですが、実際はどうなんでしょうか？
また、最終的に確定した予定表ではどんな記号が使われるのですか？ 「出と空白だけ」なのかなぁと思っているのですが。
※前月の最終１週分を 当月の計画表の頭部分にとっつけて検討しようと思っているので、 最終的に残る記号が何であるか分からないと、検討しにくいのでお聞きしております。
（半平太） 2026/04/08(水) 10:26:29
1.そうです。
2.枠外の希望休みは枠内と同じ表記でしたが、ただ今後、枠外の休みは取れなくなるとのことでしたので枠外はないものとして下さい。
3.出勤は空白、希望でとった休みは「私」、会社が決めた休みは「休」で有給は「有」です。その3種類になるかと思います。
例えば4月のＡさんなら、私と公と有の数の合計が9日あり、残りは空白になります。
よろしくお願いします。
（れもん） 2026/04/08(水) 20:35:54
＞3.出勤は空白、希望でとった休みは「私」、会社が決めた休みは「休」で有給は「有」です。その3種類になるかと思います。 ＞例えば4月のＡさんなら、私と公と有の数の合計が9日あり、残りは空白になります。 ↑
１．「公」は「休」の誤記ですね？ （それとも「公」が正しいですか？ 「私」に呼応するので）
２．「出勤」または「出」の表記はない表になるんですね？（しつこいですけど再確認させてください）
３. 「有」は誰がいつ書き込むのですか？ プログラムは、空白(出勤)と私(希望の休み）と「会社の休み」は区別できますが、 「会社の休み」が「公」か「有」か区別できないですけど、後で れもんさんが 変更するのですか？ それとも「有」は「私」の一形態であり、スタッフ自身が「私」と「有」を事前に書き込んでくれるのですか？
（半平太） 2026/04/08(水) 21:37:52
2.はい、出の所は空欄になります。
3.希望休みを出す時に（4日まで出せることになりました）私か有を明示して出します
（れもん） 2026/04/09(木) 05:01:51
2日ほど頑張りましたが、週5勤務の次の希望休日だとか祝日とか実装できませんでした。解無しの先行評価ってどうやればいいんだろ。
ちょっと再帰するだけでexcelがクラッシュしたので諦めます。
週5勤務の割り当て
出勤=0 休日=1
| [A]|[B]| [C]| [D]| [E]| [F]|
[1]| | | 1週目| 2週目| 3週目| 4週目|
[2]|6連勤| 人| n週目|n+1周目| | |
[3]| | A|0000011|0001010|0001100|0001010|
[4]| | B|0101000|0011000|0110000|0100010|
[5]| | C|0010001|0000110|1001000|0011000|
[6]| | D|1000100|0001100|0001001|1000001|
[7]| | E|0001001|0000011|1100000|1010000|
[8]| | F|0100010|0110000|0100010|0110000|
[9]| | G|0110000|0100001|0000110|0001001|
[10]| | H|1000100|1100000|1000001|0001100|
[11]| |sum|2322223|1323232|3313222|2234122|
マスタ:$B$17:=LET(
_all, BASE(SEQUENCE(2^7), 2, 7),
_reg6, "0{6,}",
_opt, CHOOSE(1, "11", "^(0*11+0*)+$"),
_off2, FILTER(_all, (LEN(_all)-LEN(SUBSTITUTE(_all,"1","")))=2),
_pats, FILTER(_off2, REGEXTEST(_off2, _reg6)=FALSE),
_cross, TOCOL(_pats & TRANSPOSE(_pats)),
_valid, FILTER(_cross, (REGEXTEST(_cross, _reg6)=FALSE) * REGEXTEST(_cross, _opt)),
_thisW, LEFT(_valid, 7),
_nextW, RIGHT(_valid, 7),
_uThis, UNIQUE(_thisW),
_baseList, IFERROR( DROP(REDUCE({"今週","翌週"}, _uThis, LAMBDA(acc,w,
VSTACK(acc, HSTACK(w, TRANSPOSE(UNIQUE(FILTER(_nextW,(_nextW<>_thisW)*( _thisW = w))))))
)), 1),""),
_refCount, BYROW(--(_baseList<>""), SUM) - 1,
_targetCol, TAKE(_baseList, , 1),
_referencedCount, MAP(_targetCol, LAMBDA(c, SUM(--(DROP(_baseList, , 1)=c)))),
_combined, HSTACK(_referencedCount, _refCount, _baseList),
SORTBY(_combined, _referencedCount, 1, _refCount, -1)
)
6連勤チェック
$A$3:=SEARCH("000000",CONCAT(C3:BB3))
初週
$B$3:=LET(
_com1, "7日分の出勤パターンを出力 0:出勤 1:休み",
_all, BASE(SEQUENCE(2^7)-1, 2, 7),
_pats, FILTER(_all, (LEN(_all) - LEN(SUBSTITUTE(_all, "1", ""))) = 2),
_dec, MAP(_pats, BIN2DEC),
_com2, "2人ペア(休みが重ならない)の全リスト作成",
_grid2, BITAND(_dec, TRANSPOSE(_dec)),
_n, ROWS(_pats),
_notSelf, SEQUENCE(_n) < TRANSPOSE(SEQUENCE(_n)),
_rIdx2, TOCOL(IF((_grid2=0)*_notSelf, SEQUENCE(_n), NA()), 2),
_cIdx2, TOCOL(IF((_grid2=0)*_notSelf, TRANSPOSE(SEQUENCE(_n)), NA()), 2),
_pair2Master, HSTACK(INDEX(_pats, _rIdx2), INDEX(_pats, _cIdx2)),
_pair2Sum, INDEX(_pair2Master,,1) + INDEX(_pair2Master,,2),
_com3, "4人セット(休み0がなく、かつ4人が全員違うパターン)の抽出",
_p2Uniq, UNIQUE(_pair2Sum),
_n4, ROWS(_p2Uniq),
_notSelf4, SEQUENCE(_n4) <= TRANSPOSE(SEQUENCE(_n4)),
_rIdx4, TOCOL(IF(_notSelf4, SEQUENCE(_n4), NA()), 2),
_cIdx4, TOCOL(IF(_notSelf4, TRANSPOSE(SEQUENCE(_n4)), NA()), 2),
_p2A, INDEX(_p2Uniq, _rIdx4),
_p2B, INDEX(_p2Uniq, _cIdx4),
_checkUniq4, MAP(_p2A, _p2B, LAMBDA(a,b, LET(
_listA, FILTER(_pair2Master, _pair2Sum = a),
_indivA, INDEX(_listA, 1, 0),
_listB, FILTER(_pair2Master, _pair2Sum = b),
_indivB, INDEX(_listB, 1, 0),
_all4, VSTACK(INDEX(_indivA, 1), INDEX(_indivA, 2), INDEX(_indivB, 1), INDEX(_indivB, 2)),
ROWS(UNIQUE(_all4)) = 4
))),
_set4Raw, TEXT(_p2A + _p2B, "0000000"),
_valid4Idx, NOT(ISNUMBER(FIND("0", _set4Raw))) * _checkUniq4,
_pair4Master, FILTER(HSTACK(_p2A, _p2B, _set4Raw), _valid4Idx),
_com4, "8人セット(休み4がなく、4人組の組み合わせ)の抽出",
_p4Uniq, UNIQUE(INDEX(_pair4Master,,3)),
_n8, ROWS(_p4Uniq),
_notSelf8, SEQUENCE(_n8) <= TRANSPOSE(SEQUENCE(_n8)),
_rIdx8, TOCOL(IF(_notSelf8, SEQUENCE(_n8), NA()), 2),
_cIdx8, TOCOL(IF(_notSelf8, TRANSPOSE(SEQUENCE(_n8)), NA()), 2),
_set8Raw, TEXT(INDEX(_p4Uniq, _rIdx8) + INDEX(_p4Uniq, _cIdx8), "0000000"),
_valid8Idx, NOT(ISNUMBER(FIND("4", _set8Raw))),
_pair8Master, FILTER(HSTACK(INDEX(_p4Uniq, _rIdx8), INDEX(_p4Uniq, _cIdx8), _set8Raw), _valid8Idx),
_com5, "ランダム選出と分解プロセス",
_pick8, INDEX(_pair8Master, RANDBETWEEN(1, ROWS(_pair8Master)), 0),
_getPairFrom4, LAMBDA(t, LET(
_c, FILTER(_pair4Master, INDEX(_pair4Master,,3) = t),
INDEX(_c, RANDBETWEEN(1, ROWS(_c)), 0)
)),
_p4A_sub, _getPairFrom4(INDEX(_pick8, 1)),
_p4B_sub, _getPairFrom4(INDEX(_pick8, 2)),
_getIndivFrom2, LAMBDA(t, LET(
_c, FILTER(_pair2Master, _pair2Sum = t),
INDEX(_c, RANDBETWEEN(1, ROWS(_c)), 0)
)),
_res1, _getIndivFrom2(INDEX(_p4A_sub, 1)),
_res2, _getIndivFrom2(INDEX(_p4A_sub, 2)),
_res3, _getIndivFrom2(INDEX(_p4B_sub, 1)),
_res4, _getIndivFrom2(INDEX(_p4B_sub, 2)),
_com6, "最終出力",
_final, VSTACK(
{"名前","パターン"},
HSTACK("選択パターン", INDEX(_pick8, 3)),
HSTACK("A", INDEX(_res1, 1, 1)), HSTACK("B", INDEX(_res1, 1, 2)),
HSTACK("C", INDEX(_res2, 1, 1)), HSTACK("D", INDEX(_res2, 1, 2)),
HSTACK("E", INDEX(_res3, 1, 1)), HSTACK("F", INDEX(_res3, 1, 2)),
HSTACK("G", INDEX(_res4, 1, 1)), HSTACK("H", INDEX(_res4, 1, 2))
),
DROP(_final,2)
)
n+1周
$D$3:=LET(_preW,C3:C10,
_masarr,$B$17#,
_mas,INDEX(_masarr,0,3),
_mas2,DROP(_masarr,,3),
_ref,INDEX(_masarr,0,2),
_cnt, ROWS(_preW),
_coment1,"並べ替え順の決定",
_order, SORTBY(HSTACK(SEQUENCE(_cnt),_preW), MAP(_preW,LAMBDA(p,XLOOKUP(p,_mas,_ref,99))),1, RANDARRAY(_cnt),1),
_sortedW, CHOOSECOLS(_order,2),
_res, REDUCE(
LET(_a,XLOOKUP(INDEX(_sortedW,1),_mas,_mas2,""),INDEX(_a,MATCH(TRUE,_a<>"",0))),
DROP(_sortedW,1),
LAMBDA(acc,preW,
LET(
_arr, XLOOKUP(preW, _mas, _mas2, ""),
_filter, FILTER(_arr, (_arr<>"")*ISNA(MATCH(_arr, acc, 0)), ""),
_coment2,"重み付け抽選",
_weightedChoice, LAMBDA(_candidates,
LET(
_w, MAP(_candidates, LAMBDA(v, XLOOKUP(v, _mas, _ref, 0))),
_cum, SCAN(0, _w, LAMBDA(a,b, a+b)),
INDEX(_candidates, XMATCH(RAND() * MAX(_cum), _cum, 1))
)
),
_coment3,"未選出から抽出",
_val, IFERROR(_weightedChoice(_filter), _weightedChoice(FILTER(_arr, _arr<>"", ""))),
VSTACK(acc, _val)
)
)
),
_coment4,"元の順序に戻す",
SORTBY(_res, CHOOSECOLS(_order,1),1)
)
（ちくわ） 2026/04/09(木) 13:39:24
調べたらこれはマクロでなくて関数なんですね。
関数でここまでできるんですね。
家のPCがバージョンが２０１９だったので
試せませんでした。
が、今後の参考にしたいと思います。
ありがとうございました。
（れもん） 2026/04/09(木) 20:35:34
１．準備 新規ブックを挿入する Sheet1のシート見出しを右クリックして「コードの表示(V)」を選ぶ 後記１の「一回こっ切り」のコードをコピペして、F5キーを押下する。(マクロが実行される） 以上でコードは用済みになったので、Ctrl + Z で元に戻す(＝まっさらになる）
同じ場所に後記２のコードを全部コピペする。
Alt+F11でエクセルに戻る。
２．本番 原本シートのA1セルに月初を入れる(例：4/1） スタッフさんに希望の休日を入れて貰ってください。
希望休が出揃ったら、前月(例：3月）のシフト表から、最後の1週間（3/25から3/31） の実績を「D3セル以下にコピペ」する (これをしないと空白が全て出勤と見做され、シフトの計算がめちゃくちゃになるので、忘れないようにしてください。）
作業シートの「B1セル」か「BB1セル」を右クリックするとシフト案が作成されます。
出来栄えが BB2:BK13 に表示されますので、よければ採用。 気に食わなければ、何度でも作業シートの「B1セル」か「BB1セル」を右クリックしてください。
※適宜、原本の祭日(C14セル以下）をメンテしてください。
<作業シート 結果例> 行 ____A____ ___B___ _____C_____ _D_ _E_ _F_ _G_ _H_ _I_ _J_ _K_ _L_ AK AL AM AN AO AP BA ____BB____ ___BC___ __BD__ ___BE___ ____BF____ BG BH BI BJ BK 1 2026/4/1 25 26 27 28 29 30 31 1 2 27 28 29 30 1 2 : 週別出勤数→ 2 名 基準 規定稼働日 水 木 金 土 日 月 火 水 木 月 火 水 木 金 土 : 6連続件数 月出勤数 過不足 月与休数 土日出勤数 3 A 月平日 21 休 休 休 休 : 0 21 0 9 4 4 B 月平日 21 休 休 : 0 21 0 9 4 5 C 月平日 21 休 休 休 休 : 0 21 0 9 4 6 D 月平日 21 休 有 休 : 0 21 0 9 4 7 E 週5日 5 休 休 休 休 : 0 20 4 5 5 5 5 5 8 F 週5日 5 有 休 休 休 : 0 22 4 5 5 5 5 5 9 G 週4日 4 有 休 休 休 休 休 休 : 0 19 4 4 4 4 4 4 10 H 週3日 3 休 有 休 休 休 休 休 休 休 : 0 12 4 3 3 3 3 3 11 12 13 祭日 6 6 6 6 5 6 14 4月29日 15 5月3日 16 5月4日
’１-----------準備プログラムを貼り付けて、１回実行後消去する(Ctrl+Zで白紙に戻す） Private Sub 一回こっ切り()
Worksheets.Add(, Sheets(Sheets.Count)).Name = "原本"
With Sheets("原本")
Rem 標準外書式セルをまとめて処理
.Range("A1,C1").NumberFormatLocal = "yyyy/m/d"
.Range("D1:AV1").NumberFormatLocal = "d"
.Range("D2:AV2").NumberFormatLocal = "aaa"
.Range("C14").NumberFormatLocal = "m""月""d""日"""
Rem 名前定義
.Parent.Names.Add Name:="祭日", RefersToR1C1:="=原本!R14C3:R50C3"
Rem 生データのセルをまとめて処理
.Range("A1").Value = 46113
.Range("A2").Value = "名"
.Range("B2").Value = "基準"
.Range("C2").Value = "規定稼働日"
.Range("A3").Value = "A"
.Range("B3:B6").Value = "月平日"
.Range("D3:G5,J3,I4:J5,D6:E6,G6:I6,E7:F7,I7:J7").Value = ""
.Range("D8:F8,J8,D9:E9,I9,F10,H10:I10").Value = ""
.Range("H3:I3,H4:H5,F6,D7,G7,I8,G9:H9,J9:J10,D10,G10").Value = "休"
.Range("A4").Value = "B"
.Range("A5").Value = "C"
.Range("A6").Value = "D"
.Range("J6,G8,F9,E10").Value = "有"
.Range("A7").Value = "E"
.Range("B7:B8").Value = "週5日"
.Range("A8").Value = "F"
.Range("A9").Value = "G"
.Range("B9").Value = "週4日"
.Range("A10").Value = "H"
.Range("B10").Value = "週3日"
.Range("C13").Value = "祭日"
.Range("C14").Value = 46141
.Range("C15").Value = 46145
.Range("C16").Value = 46146
Rem 数式セルをまとめて処理
.Range("D1").FormulaR1C1Local = "=EOMONTH(RC[-3],-1)-6"
.Range("E1:AV1").FormulaR1C1Local = "=IF(RC[-1]="""","""",IF(RC[-1]+1>EOMONTH(RC1,0)+7,"""",RC[-1]+1))"
.Range("D2:AV2").FormulaR1C1Local = "=TEXT(R[-1]C,""aaa"")"
.Range("C3:C10").FormulaR1C1Local = "=IF(MID(RC[-1],2,1)=""平"",NETWORKDAYS(R1C[-2],EOMONTH(R1C[-2],0),祭日),MID(RC[-1],2,1)*1)"
End With
Me.name = "作業"
Me.Select
End Sub
’２-----------本番プログラムを貼り付ける(以下最下行まで）
Private posOvFstDayMon As Long Private PosOvFstSun As Long Private PosOvFinalWeekSat
Private lastRow As Long Private maxStaffs As Long, maxDays As Long Private rNames As Range, rDates As Range, ky As Variant Private holdys As Range, msg1, msg2, App As Application Private overViewAry(), overViewAryChanged() Private sortedLst As Object Private EOM
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address(0, 0) = "B1" Or Target.Address(0, 0) = "BB1" Then
Cancel = True
Main
End If
End Sub
Sub Main()
Dim Msg As String
Dim Trial As Long
For Trial = 1 To 25 '多目だと遅くなるが、6連続無しは増える。
initialize
App.ScreenUpdating = False
土日割振り
週間割振り '単純割り振り
月間勤務調整
列平準化
If 連続6無し Then '6連続チェック
Exit For
End If
Next Trial
結果表示
App.Goto Range("AH1"), True
Columns("A:BK").EntireColumn.AutoFit
App.ScreenUpdating = True
Msg = series6(overViewAry)
MsgBox "完了" & vbCrLf & vbCrLf & "6連続以上" & _
IIf(Msg = "", "はありません", vbCrLf & Msg)
'イミディエイトウィンドウにも出力
Debug.Print "完了" & vbCrLf & vbCrLf & "6連続以上" & _
IIf(Msg = "", "はありません", vbCrLf & Msg)
End Sub
Private Sub initialize() '初期化＆データ転記(作業シートへ)
Set App = Application
Set sortedLst = CreateObject("System.Collections.SortedList")
Set holdys = App.Range("祭日")
Me.UsedRange.ClearContents
With Worksheets("原本")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row ' 最下行
maxStaffs = lastRow - 2 'スタッフ数
maxDays = Day(App.EoMonth(.Range("A1"), 0)) '当月日数
.UsedRange.Copy '作業シートへ転記
End With
'転記データ貼り付け
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats, xlNone, False, False
Set rNames = Range("A3").Resize(maxStaffs, 3) '氏名範囲
Set rDates = Range("D1").Resize(1, maxDays + 14) '当月の処理日付範囲(前後1週間付加)
'前月の「空白」を「出」に変更。 「休」を「空白」に変更。
Range("D3").Resize(maxStaffs, 7).Replace "", "出", xlWhole
Range("D3").Resize(maxStaffs, 7).Replace "休", "", xlWhole
'当月の「空白」を「可」に変更
Range("K3").Resize(maxStaffs, maxDays + 7).Replace "", "可", xlWhole
Range("D1").Resize(1, maxDays + 14).NumberFormatLocal = "d" '日付の書式をdに設定
Range("D1").Resize(maxStaffs + 2, maxDays + 14).HorizontalAlignment = xlCenter
'データ格納
overViewAry = Range("D3").Resize(maxStaffs, maxDays + 15).Value '1列余分格納
posOvFstDayMon = 8
PosOvFstSun = App.Match([A1-WEEKDAY(A1)+1], rDates, 0)
EOM = [EOMONTH(A1,0)]
PosOvFinalWeekSat = App.Match([EOMONTH(A1,0)-WEEKDAY(EOMONTH(A1,0))+7], rDates, 0)
End Sub
Private Sub 土日割振り() '作業シートで処理
Dim SatSunBal() '土日担当回数
Dim SatSunLeft() As Long '土日可能残数
Dim RW As Long, CL As Long, Cnt As Long
Dim srtInd As Long, priorityKey As Variant
Dim fixedInd As Long, Idx As Long, rd
Dim lastWeekSat
ReDim SatSunBal(1 To maxStaffs) 'Staff別 土日担当回数 初期化
'土日が可能な人の情報を集めて、出来るだけ均等に割り振る
lastWeekSat = EOM - Weekday(EOM) + 7
For CL = 1 To PosOvFinalWeekSat - 7 '最終日の属する週の土曜まで(初日スタート基準)
Cnt = 0
sortedLst.Clear
If Weekday(rDates(1, CL + 7) - 1) > 5 Then '土日に該当
rd = getRndAry(maxStaffs) '各土日で誰を先に処理するかを決める乱数を発生
ReDim SatSunLeft(1 To maxStaffs) '土日担当可能残数 初期化
Call bookWeekendLeft(CL, SatSunLeft) 'SatSunLeftに土日担当可能残を記録
For Idx = 1 To maxStaffs
If overViewAry(Idx, CL + 7) = "可" Then
ky = "KEY" & Format(SatSunBal(Idx) * 10000 + _
SatSunLeft(Idx) * 100 + rd(Idx, 1), "000000")
sortedLst.Add ky, Idx
End If
Next Idx
If sortedLst.Count Then
For srtInd = 0 To App.Min(4, sortedLst.Count) - 1
'KEYに従ってStaffを取り出す
priorityKey = sortedLst.Getkey(srtInd)
fixedInd = sortedLst(priorityKey)
'SatSunBalをカウントアップ
SatSunBal(fixedInd) = SatSunBal(fixedInd) + 1
'overViewAryをアップデート
overViewAry(fixedInd, CL + 7) = "出"
Next srtInd
End If
End If
Next CL
End Sub
Private Sub 週間割振り() '週間基準で単純に割り振る
Dim Idx As Long, CL As Long, orderAry, Limit
Dim weekIdx As Long, eachDay As Long
Dim 出勤確定数 As Long
Dim 出勤可能数 As Long
Dim wkdyInWeek
Dim nn As Long, newlyFixedCnt As Long
For Idx = 1 To maxStaffs '個人別に週内割当
wkdyInWeek = App.Min(rNames(Idx, 3), 5)
For weekIdx = PosOvFstSun To 7 * 6 + PosOvFstSun - 1 Step 7
If rDates(1, weekIdx) > App.EoMonth(Range("A1"), 0) Then
Exit For
Else
orderAry = getRndAry(7) '7日分の乱数配列を取得する（２次元配列)
orderAry(1, 1) = 999 '土日は禁止する
orderAry(7, 1) = 999
出勤確定数 = 0
出勤可能数 = 0
For eachDay = 1 To 7
出勤確定数 = 出勤確定数 + IIf(Left(overViewAry(Idx, weekIdx + eachDay - 1), 1) = "出", 1, 0)
出勤可能数 = 出勤可能数 + IIf(overViewAry(Idx, weekIdx + eachDay - 1) = "可", 1, 0)
If overViewAry(Idx, weekIdx + eachDay - 1) <> "可" Then '出以外に空白もあり
orderAry(eachDay, 1) = 999
End If
Next eachDay
End If
newlyFixedCnt = 0 '初期化
For nn = 1 To App.Min(出勤可能数, wkdyInWeek - 出勤確定数)
If App.Small(orderAry, nn) <> 999 Then
overViewAry(Idx, weekIdx + _
App.Match(App.Small(orderAry, nn), orderAry, 0) - 1) = "出-"
newlyFixedCnt = newlyFixedCnt + 1
If newlyFixedCnt > wkdyInWeek Then
Exit For
End If
End If
Next nn
Next weekIdx
Next Idx
End Sub
Private Sub 月間勤務調整()
Dim 日別人数ary
Dim i As Long, Idx As Long, CL As Long
Dim wkDays, sa, itm
sortedLst.Clear
日別人数ary = get日別人数(1, maxDays)
For i = 1 To maxDays
sortedLst.Add Format(日別人数ary(i) * 100 + i, "0000"), Empty
Next i
wkDays = OutWorkPerMonth
For Idx = 1 To maxStaffs
If rNames(Idx, 3) > 7 Then '月間勤務数契約者
sa = wkDays(Idx) - rNames(Idx, 3)
If sa > 0 Then
For i = sortedLst.Count - 1 To 0 Step -1
itm = sortedLst.Getkey(i)
CL = Val(Right(itm, 2))
If Left(overViewAry(Idx, CL + 7), 1) = "出" Then
overViewAry(Idx, CL + 7) = "可"
sa = sa - 1
sortedLst.removeat (i)
If sa = 0 Then
Exit For
End If
End If
Next i
End If
End If
Next
End Sub
Private Sub 列平準化()
Dim k As Long
Dim ovCL As Long, RW As Long
Dim weekIdx As Long
Dim sm
Dim MN As Long, MX As Long, ovwIdx As Long
Dim xCL As Long, nCL As Long
Dim fin As Boolean, circuitBrk As Long
'同一週内で「出」と「可」を入れ替える
For weekIdx = PosOvFstSun To 7 * 6 + PosOvFstSun - 1 Step 7
sortedLst.Clear
If rDates(1, weekIdx) > App.EoMonth(Range("A1"), 0) Then '来月日曜なら終了
Exit For
Else
For ovCL = weekIdx To weekIdx + 6 '1週間単位で列別の調整を行う
sm = 0
If 8 <= ovCL And ovCL <= PosOvFinalWeekSat Then
For RW = 1 To maxStaffs
sm = sm + IIf(Left(overViewAry(RW, ovCL), 1) = "出", 1, 0)
Next RW
'土日4人は無視する
If (rDates(2, ovCL) <> "土" And rDates(2, ovCL) <> "日") Or sm <> 4 Then
ky = Format(sm * 100 + ovCL, "0000")
sortedLst.Add (ky), Empty
End If
End If
Next ovCL
circuitBrk = 0
fin = False
Do Until fin Or circuitBrk > 3
MX = Left(sortedLst.Getkey(sortedLst.Count - 1), 2)
MN = Left(sortedLst.Getkey(0), 2)
xCL = Right(sortedLst.Getkey(sortedLst.Count - 1), 2)
nCL = Right(sortedLst.Getkey(0), 2)
If MX - MN > 1 Then
For ovwIdx = maxStaffs To 1 Step -1 '下(週x日タイプ）から上へ処理
If Left(overViewAry(ovwIdx, xCL), 1) = "出" And _
Left(overViewAry(ovwIdx, nCL), 1) = "可" Then
'入れ替え
overViewAry(ovwIdx, nCL) = overViewAry(ovwIdx, xCL) '「出/出-」
overViewAry(ovwIdx, xCL) = "可"
'更新
If sortedLst.Count >= 0 Then
sortedLst.removeat sortedLst.Count - 1
sortedLst.removeat 0
'再登録（ただし、土日4名になる場合は書き込まない
If (rDates(2, nCL) <> "土" And rDates(2, nCL) <> "日") _
Or (MN + 1) <> 4 Then
ky = Format((MN + 1) * 100 + nCL, "0000")
sortedLst.Add (ky), Empty
End If
If (rDates(2, xCL) <> "土" And rDates(2, xCL) <> "日") _
Or (MX - 1) <> 4 Then
ky = Format((MX - 1) * 100 + xCL, "0000")
sortedLst.Add (ky), Empty
End If
Exit For
End If
End If
Next ovwIdx
Else
fin = True
End If
circuitBrk = circuitBrk + 1
Loop
End If
Next weekIdx
End Sub
Private Function 連続6無し() As Boolean
Dim tg(), COL As Long, RW As Long, Cnt As Long
tg = overViewAry
連続6無し = True
For RW = 1 To maxStaffs
For COL = 1 To maxDays + 15 '1列余分にセットする
If Left(tg(RW, COL), 1) = "出" Then
Cnt = Cnt + 1
Else
If Cnt >= 6 Then
連続6無し = False
Exit Function
Else
Cnt = 0
End If
End If
Next COL
Next RW
End Function
Private Sub 結果表示()
Dim i As Long, deltaCL As Long, RW As Long
Dim fmlAd As String
'overViewAryを画面投射
Range("D3").Resize(UBound(overViewAry), maxDays + 14) = overViewAry
'会社表示ルールへ変換
Range("D3").Resize(maxStaffs, 7).Replace "", "休", xlWhole
With Range("D3").Resize(maxStaffs, PosOvFinalWeekSat)
.Replace "可", "休", xlWhole
.Replace "出", "", xlWhole
.Replace "出-", "", xlWhole
End With
'＜タイトル＞
Range("BB2:BG2") = Array("6連続件数", "月出勤数", "過不足", "月与休数", "土日出勤数", "週別出勤数→")
'＜連続出勤＞
Range("BB3").Resize(maxStaffs).Formula = _
"=COUNT(0/(FREQUENCY(COLUMN(A3:AS3),COLUMN(A3:AR3)*(D3:AU3<>""""))-1>=6))"
'＜出勤日数＞
Range("BC3").Resize(maxStaffs).Formula = _
"=COUNTBLANK(" & Range("K3").Resize(1, maxDays).Address(0, 0) & ")"
'＜勤務日数過不足＞
Range("BD3").Resize([Countif(B:B,"月平日")]).Formula = "=BC3-C3"
'＜オフ＞
Range("BE3").Resize([Countif(B:B,"月平日")]).Formula = _
"=COUNTIF(" & Range("K3").Resize(1, maxDays).Address(0, 0) & ",""休"")"
'＜土日出勤数＞
Range("BF3").Resize(maxStaffs).Formula = _
"=SUM(COUNTIFS(" & Range("K2").Resize(1, maxDays).Address & ",{""土"",""日""}," _
& Range("K3").Resize(1, maxDays).Address(0, 0) & ",""""))"
'＜日別出勤人数＞
Range("K13").Resize(1, maxDays).Formula = "=COUNTBLANK(K3:K10)"
'＜人別週単位別出勤日数＞
For RW = 1 To maxStaffs
deltaCL = 0
If rNames(RW, 3) < 8 Then
For i = PosOvFstSun To PosOvFinalWeekSat Step 7
fmlAd = Cells(RW + 2, rDates(1, i).Column).Resize(1, 7).Address
Cells(RW + 2, 59 + deltaCL).Formula = "=COUNTIF(" & fmlAd & ","""")"
deltaCL = deltaCL + 1
Next i
End If
Next RW
End Sub
'2次元Targetの特定行に6連続勤務があるかチェック
Private Function series6(Target) As String
Dim COL As Long, Cnt As Long, Msg
Dim tg()
Dim RW As Long
tg = Target
ReDim Preserve tg(1 To UBound(tg), 1 To UBound(tg, 2) + 1)
For RW = 1 To maxStaffs
For COL = 1 To maxDays + 15 '1列余分にセットする
If Left(tg(RW, COL), 1) = "出" Then
Cnt = Cnt + 1
Else
If Cnt >= 6 Then
If Month(rDates(1, COL - 1)) = 2 Then Stop
If rDates(1, COL - Cnt) = 2 Then Stop
Msg = Msg & vbCrLf & rNames(RW, 1) & "さん " & _
rDates(1, COL - Cnt) & "-" & rDates(1, COL - 1)
End If
Cnt = 0
End If
Next COL
Next RW
series6 = Msg
End Function
Private Function get日別人数(st As Long, ed As Long)
Dim CL As Long, RW As Long, sm As Long
Dim workingByDay() As Long
ReDim workingByDay(1 To ed - st + 1)
For CL = st To ed 'maxDays
sm = 0
For RW = 1 To maxStaffs
If Left(overViewAry(RW, CL + posOvFstDayMon - 1), 1) = "出" Then
sm = sm + 1
End If
Next RW
workingByDay(CL - st + 1) = sm
Next CL
get日別人数 = workingByDay
End Function
Private Function OutWorkPerMonth() '月間出勤日数(OverViewから算出する)
Dim Idx As Long
Dim DyIdx As Long
Dim temp As Long
Dim monthWrking()
ReDim monthWrking(1 To maxStaffs)
For Idx = 1 To maxStaffs
If rNames(Idx, 3) > 7 Then
temp = 0
For DyIdx = posOvFstDayMon To posOvFstDayMon + maxDays - 1
If Left(overViewAry(Idx, DyIdx), 1) = "出" Then
temp = temp + 1
End If
Next DyIdx
monthWrking(Idx) = temp
End If
Next Idx
OutWorkPerMonth = monthWrking
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, Evaluate("ROW(1:" & n & ")"))
getRndAry = App.Match(randomOrder, myRnd, 0) '乱数の順位配列
End Function
'残りの土日で担当できる日数をSatSunLeftに格納
Private Sub bookWeekendLeft(CL As Long, SatSunLeft)
Dim i As Long
Dim Idx As Long
Dim RW As Long
For i = CL + 1 To maxDays
If Weekday(rDates(1, i + 7) - 1) > 5 Then
For Idx = 1 To maxStaffs
If overViewAry(Idx, i + 7) = "可" Then
SatSunLeft(Idx) = SatSunLeft(Idx) + 1
End If
Next Idx
End If
Next i
End Sub
（半平太） 2026/04/12(日) 22:30:52
できました。ちょっと感動しています。。。
もうあきらめていましたが、こんな事が可能なんですね。
しくみはわかりませんが、理解できるようになりたいな。
どうもありがとうございました！！！
（れもん） 2026/04/14(火) 20:59:32
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.