Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – シフト表自動生成

Excel VBA
スポンサーリンク

ねらい：希望・役割・公平性を満たしながら、月次シフトを一撃で自動生成する

シフトは「希望（出勤可）」「役割（必要人数とスキル）」「制約（最大勤務・連続勤務・前後夜勤）」「公平性（偏り防止）」を同時に満たす必要があります。VBAなら“配列I/O＋辞書＋制約チェック＋ラウンドロビン”の型で、月次表を一瞬で組めます。初心者でも貼って動くテンプレを、入力仕様→生成ロジック→コード→整形→例題の順にかみ砕いて解説します。

入力仕様：スタッフ属性と希望、必要人数と役割定義

シート構成と列の意味

  • Staff（スタッフ属性）: A=Name, B=Role, C=MaxMonthShifts, D=MaxConsecDays, E=AvoidNightAfter, F=WeekendWeight
    • 例：山田, Manager, 20, 3, Y, 1.2
  • Needs（必要人数）: A=Date(yyyy-mm-dd), B=AM_Need(Role=Manager), C=AM_Need(Role=Staff), D=PM_Need(Manager), E=PM_Need(Staff), F=N_Need(Manager), G=N_Need(Staff)
    • 例：2026-01-01,1,2,1,2,0,0
  • Avail（出勤可）: A=Name, B=Date, C=AM, D=PM, E=N（Y/Nで可否）
    • 例：山田,2026-01-01,Y,N,N

重要ポイントの深掘り

  • 役割別ニーズを明記:「AMにManager1名＆Staff2名」など、時間帯×役割の必要数を列で持つとロジックがシンプルになります。
  • 希望は“Y/N”で軽く表現: 細かい優先度は後述の重み（WeekendWeightなど）で調整します。
  • 制約は属性として保持: 月最大勤務、連続勤務上限、“夜勤翌日は回避”などを列で与えます。

共通基盤：配列I/O・キー・スロット定義

ユーティリティとスロット表現

' ModShift_Base.bas
Option Explicit
Private Const SEP As String = Chr$(30)

Public Function ReadRegion(ws As Worksheet, Optional topLeft As String = "A1") As Variant
    ReadRegion = ws.Range(topLeft).CurrentRegion.Value
End Function

Public Sub WriteBlock(ws As Worksheet, a As Variant, topLeft As String)
    ws.Range(topLeft).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

Public Function Norm(ByVal s As Variant) As String
    Norm = LCase$(Trim$(CStr(s)))
End Function

Public Function SlotKey(ByVal dt As Date, ByVal slot As String, ByVal role As String) As String
    SlotKey = Format$(dt, "yyyy-mm-dd") & SEP & slot & SEP & role
End Function

Public Function PrepareOut(name As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next: Set ws = Worksheets(name): On Error GoTo 0
    If ws Is Nothing Then Set ws = Worksheets.Add: ws.Name = name
    ws.Cells.Clear
    Set PrepareOut = ws
End Function
VB

重要ポイントの深掘り

  • スロットは「日付×時間帯×役割」キー: AM/PM/N × Role を別問題として割り切ると、必要数と充足チェックが一貫します。
  • 配列中心→一括書き戻し: 逐次セル操作は遅い。配列で結果を作り、最後に一括出力します。

生成ロジック：希望→制約→公平性の順で割り当てる

割り当ての基本手順

  • 候補抽出: そのスロットに対して「出勤可（Y）」かつ役割一致のスタッフを集合化。
  • 制約チェック: 月最大勤務、連続勤務上限、夜勤翌日の回避、当日多重割り当てなし。
  • 公平性ラウンドロビン: 前回の割り当て位置から回し、割り当て件数・週末重みでバランス。
  • 充足確認＆不足マーキング: 必要人数に満たない場合は“UNFILLED”を記録して後続の埋め戻し対象に。

重要ポイントの深掘り

  • 制約は“拒否条件”にする: 先に弾いてから公平性で選ぶと、ロジックが単純で壊れません。
  • 週末や特定枠の偏り回避: WeekendWeightで土日希望者を優先するなど、重みを加味した並び替えが効きます。

コード全体：月次シフトの自動生成（AM/PM/N＋役割別）

シフト自動生成テンプレ（貼って動く）

' ModShift_Generate.bas
Option Explicit

Public Sub GenerateMonthlyShift(ByVal year As Long, ByVal month As Long)
    Dim wsStaff As Worksheet: Set wsStaff = Worksheets("Staff")
    Dim wsAvail As Worksheet: Set wsAvail = Worksheets("Avail")
    Dim wsNeeds As Worksheet: Set wsNeeds = Worksheets("Needs")
    Dim staff As Variant: staff = ReadRegion(wsStaff)
    Dim avail As Variant: avail = ReadRegion(wsAvail)
    Dim needs As Variant: needs = ReadRegion(wsNeeds)

    Dim startDate As Date: startDate = DateSerial(year, month, 1)
    Dim endDate As Date: endDate = DateSerial(year, month + 1, 0)

    ' インデックス：Name→属性
    Dim idxRole As Object: Set idxRole = CreateObject("Scripting.Dictionary")
    Dim idxMaxMonth As Object: Set idxMaxMonth = CreateObject("Scripting.Dictionary")
    Dim idxMaxConsec As Object: Set idxMaxConsec = CreateObject("Scripting.Dictionary")
    Dim idxAvoidNightAfter As Object: Set idxAvoidNightAfter = CreateObject("Scripting.Dictionary")
    Dim idxWeekendWeight As Object: Set idxWeekendWeight = CreateObject("Scripting.Dictionary")

    Dim i As Long
    For i = 2 To UBound(staff, 1)
        Dim nm As String: nm = CStr(staff(i, 1))
        idxRole(nm) = CStr(staff(i, 2))
        idxMaxMonth(nm) = Val(CStr(staff(i, 3)))
        idxMaxConsec(nm) = Val(CStr(staff(i, 4)))
        idxAvoidNightAfter(nm) = (UCase$(CStr(staff(i, 5))) = "Y")
        idxWeekendWeight(nm) = IIf(Len(CStr(staff(i, 6))) > 0, CDbl(staff(i, 6)), 1#)
    Next

    ' 可用性：Date|Slot → Collection of Names
    Dim avMap As Object: Set avMap = CreateObject("Scripting.Dictionary")
    Dim r As Long
    For r = 2 To UBound(avail, 1)
        Dim nm As String: nm = CStr(avail(r, 1))
        Dim dt As Date: dt = CDate(avail(r, 2))
        If UCase$(CStr(avail(r, 3))) = "Y" Then AddAvail avMap, dt, "AM", nm
        If UCase$(CStr(avail(r, 4))) = "Y" Then AddAvail avMap, dt, "PM", nm
        If UCase$(CStr(avail(r, 5))) = "Y" Then AddAvail avMap, dt, "N", nm
    Next

    ' ニーズ：Date×Slot×Role → need数
    Dim needMap As Object: Set needMap = CreateObject("Scripting.Dictionary")
    For r = 2 To UBound(needs, 1)
        Dim ndt As Date: ndt = CDate(needs(r, 1))
        SetNeed needMap, ndt, "AM", "Manager", Val(CStr(needs(r, 2)))
        SetNeed needMap, ndt, "AM", "Staff", Val(CStr(needs(r, 3)))
        SetNeed needMap, ndt, "PM", "Manager", Val(CStr(needs(r, 4)))
        SetNeed needMap, ndt, "PM", "Staff", Val(CStr(needs(r, 5)))
        SetNeed needMap, ndt, "N", "Manager", Val(CStr(needs(r, 6)))
        SetNeed needMap, ndt, "N", "Staff", Val(CStr(needs(r, 7)))
    Next

    ' 実績・統計
    Dim monthCount As Object: Set monthCount = CreateObject("Scripting.Dictionary")
    Dim consecCount As Object: Set consecCount = CreateObject("Scripting.Dictionary")
    Dim lastWorkedDate As Object: Set lastWorkedDate = CreateObject("Scripting.Dictionary")
    Dim lastWorkedSlot As Object: Set lastWorkedSlot = CreateObject("Scripting.Dictionary")

    ' 出力準備
    Dim wsOut As Worksheet: Set wsOut = PrepareOut("Shift_" & year & "_" & Format$(month, "00"))
    Dim out() As Variant: ReDim out(1 To 1, 1 To 8)
    out(1, 1) = "Date": out(1, 2) = "AM_Manager": out(1, 3) = "AM_Staff"
    out(1, 4) = "PM_Manager": out(1, 5) = "PM_Staff"
    out(1, 6) = "N_Manager": out(1, 7) = "N_Staff": out(1, 8) = "Notes"
    Dim outRow As Long: outRow = 1

    Dim d As Date
    For d = startDate To endDate
        outRow = outRow + 1
        ReDim Preserve out(1 To outRow, 1 To 8)
        out(outRow, 1) = d

        Dim notes As String: notes = ""

        ' 時間帯×役割で割り当て
        AssignRoleSlot out, outRow, d, "AM", "Manager", 2, idxRole, avMap, needMap, monthCount, consecCount, lastWorkedDate, lastWorkedSlot, idxMaxMonth, idxMaxConsec, idxAvoidNightAfter, idxWeekendWeight, notes
        AssignRoleSlot out, outRow, d, "AM", "Staff", 3, idxRole, avMap, needMap, monthCount, consecCount, lastWorkedDate, lastWorkedSlot, idxMaxMonth, idxMaxConsec, idxAvoidNightAfter, idxWeekendWeight, notes

        AssignRoleSlot out, outRow, d, "PM", "Manager", 4, idxRole, avMap, needMap, monthCount, consecCount, lastWorkedDate, lastWorkedSlot, idxMaxMonth, idxMaxConsec, idxAvoidNightAfter, idxWeekendWeight, notes
        AssignRoleSlot out, outRow, d, "PM", "Staff", 5, idxRole, avMap, needMap, monthCount, consecCount, lastWorkedDate, lastWorkedSlot, idxMaxMonth, idxMaxConsec, idxAvoidNightAfter, idxWeekendWeight, notes

        AssignRoleSlot out, outRow, d, "N", "Manager", 6, idxRole, avMap, needMap, monthCount, consecCount, lastWorkedDate, lastWorkedSlot, idxMaxMonth, idxMaxConsec, idxAvoidNightAfter, idxWeekendWeight, notes
        AssignRoleSlot out, outRow, d, "N", "Staff", 7, idxRole, avMap, needMap, monthCount, consecCount, lastWorkedDate, lastWorkedSlot, idxMaxMonth, idxMaxConsec, idxAvoidNightAfter, idxWeekendWeight, notes

        out(outRow, 8) = notes
    Next

    WriteBlock wsOut, out, "A1"
    FormatShiftView wsOut, "A1"
    MsgBox "シフト自動生成が完了しました。", vbInformation
End Sub

Private Sub AddAvail(ByVal avMap As Object, ByVal dt As Date, ByVal slot As String, ByVal nm As String)
    Dim k As String: k = Format$(dt, "yyyy-mm-dd") & SEP & slot
    If Not avMap.Exists(k) Then
        Dim col As New Collection: col.Add nm: Set avMap(k) = col
    Else
        avMap(k).Add nm
    End If
End Sub

Private Sub SetNeed(ByVal needMap As Object, ByVal dt As Date, ByVal slot As String, ByVal role As String, ByVal cnt As Long)
    needMap(SlotKey(dt, slot, role)) = cnt
End Sub

Private Sub AssignRoleSlot(ByRef out() As Variant, ByVal outRow As Long, ByVal d As Date, ByVal slot As String, ByVal role As String, ByVal outCol As Long, _
                           ByVal idxRole As Object, ByVal avMap As Object, ByVal needMap As Object, _
                           ByVal monthCount As Object, ByVal consecCount As Object, ByVal lastWorkedDate As Object, ByVal lastWorkedSlot As Object, _
                           ByVal idxMaxMonth As Object, ByVal idxMaxConsec As Object, ByVal idxAvoidNightAfter As Object, ByVal idxWeekendWeight As Object, _
                           ByRef notes As String)
    Dim need As Long: need = IIf(needMap.Exists(SlotKey(d, slot, role)), needMap(SlotKey(d, slot, role)), 0)
    If need = 0 Then Exit Sub

    Dim kAv As String: kAv = Format$((d), "yyyy-mm-dd") & SEP & slot
    Dim candidates As Collection
    If avMap.Exists(kAv) Then Set candidates = avMap(kAv) Else Set candidates = New Collection

    Dim picks() As String: ReDim picks(1 To need)
    Dim got As Long: got = 0

    ' 候補をスコア化して公平に並べ替え
    Dim arr() As Variant: arr = CandidatesToArray(candidates)
    If UBound(arr) >= 1 Then
        SortCandidatesByScore arr, d, slot, role, idxRole, monthCount, idxWeekendWeight
    End If

    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        Dim nm As String: nm = CStr(arr(i, 1))
        If Not idxRole.Exists(nm) Then GoTo NextCand
        If LCase$(idxRole(nm)) <> LCase$(role) Then GoTo NextCand

        ' 同日多重割り当て回避
        If WorkedThisDate(nm, d, lastWorkedDate, lastWorkedSlot) Then GoTo NextCand

        ' 月最大・連続上限・夜勤翌日回避
        If ExceedsMonth(nm, monthCount, idxMaxMonth) Then GoTo NextCand
        If ExceedsConsec(nm, d, consecCount, lastWorkedDate, idxMaxConsec) Then GoTo NextCand
        If Not NightAfterOk(nm, d, slot, lastWorkedDate, lastWorkedSlot, idxAvoidNightAfter) Then GoTo NextCand

        ' 採用
        got = got + 1
        picks(got) = nm
        monthCount(nm) = IIf(monthCount.Exists(nm), monthCount(nm) + 1, 1)
        UpdateConsec nm, d, consecCount, lastWorkedDate
        lastWorkedSlot(nm) = slot
        If got = need Then Exit For
NextCand:
    Next

    If got = 0 Then
        notes = AppendNote(notes, slot & ":" & role & "=UNFILLED")
    Else
        out(outRow, outCol) = Join(picks, ", ")
        If got < need Then notes = AppendNote(notes, slot & ":" & role & "=" & got & "/" & need)
    End If
End Sub

Private Function CandidatesToArray(ByVal col As Collection) As Variant
    Dim n As Long: n = IIf(col Is Nothing, 0, col.Count)
    If n = 0 Then CandidatesToArray = Array(): Exit Function
    Dim a() As Variant: ReDim a(1 To n, 1 To 1)
    Dim i As Long: For i = 1 To n: a(i, 1) = col(i): Next
    CandidatesToArray = a
End Function

Private Sub SortCandidatesByScore(ByRef a As Variant, ByVal d As Date, ByVal slot As String, ByVal role As String, _
                                  ByVal idxRole As Object, ByVal monthCount As Object, ByVal idxWeekendWeight As Object)
    Dim i As Long, j As Long, tmp As Variant
    For i = LBound(a) To UBound(a) - 1
        For j = i + 1 To UBound(a)
            If CandidateScore(a(i, 1), d, slot, role, idxRole, monthCount, idxWeekendWeight) < _
               CandidateScore(a(j, 1), d, slot, role, idxRole, monthCount, idxWeekendWeight) Then
                tmp = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = tmp
            End If
        Next
    Next
End Sub

Private Function CandidateScore(ByVal nm As String, ByVal d As Date, ByVal slot As String, ByVal role As String, _
                                ByVal idxRole As Object, ByVal monthCount As Object, ByVal idxWeekendWeight As Object) As Double
    Dim base As Double: base = 1#
    ' バランス: 割り当てが少ないほど高得点
    Dim used As Long: used = IIf(monthCount.Exists(nm), monthCount(nm), 0)
    Dim balance As Double: balance = 1# / (1# + used)
    ' 週末優先重み
    Dim wd As Long: wd = Weekday(d, vbMonday)
    Dim isWeekend As Boolean: isWeekend = (wd >= 6)
    Dim w As Double: w = IIf(isWeekend, IIf(idxWeekendWeight.Exists(nm), idxWeekendWeight(nm), 1#), 1#)
    CandidateScore = base * balance * w
End Function

Private Function WorkedThisDate(ByVal nm As String, ByVal d As Date, ByVal lastWorkedDate As Object, ByVal lastWorkedSlot As Object) As Boolean
    WorkedThisDate = (lastWorkedDate.Exists(nm) And lastWorkedDate(nm) = d)
End Function

Private Function ExceedsMonth(ByVal nm As String, ByVal monthCount As Object, ByVal idxMaxMonth As Object) As Boolean
    ExceedsMonth = (monthCount.Exists(nm) And monthCount(nm) >= IIf(idxMaxMonth.Exists(nm), idxMaxMonth(nm), 9999))
End Function

Private Function ExceedsConsec(ByVal nm As String, ByVal d As Date, ByVal consecCount As Object, ByVal lastWorkedDate As Object, ByVal idxMaxConsec As Object) As Boolean
    Dim cur As Long: cur = IIf(consecCount.Exists(nm), consecCount(nm), 0)
    ' 連続日判定：前回が前日なら+1、離れてればリセット（Assign時に更新するためここは参照のみ）
    ExceedsConsec = (cur >= IIf(idxMaxConsec.Exists(nm), idxMaxConsec(nm), 9999))
End Function

Private Function NightAfterOk(ByVal nm As String, ByVal d As Date, ByVal slot As String, ByVal lastWorkedDate As Object, ByVal lastWorkedSlot As Object, ByVal idxAvoidNightAfter As Object) As Boolean
    If Not idxAvoidNightAfter.Exists(nm) Then NightAfterOk = True: Exit Function
    If Not idxAvoidNightAfter(nm) Then NightAfterOk = True: Exit Function
    If Not lastWorkedDate.Exists(nm) Then NightAfterOk = True: Exit Function
    NightAfterOk = Not (lastWorkedDate(nm) = DateAdd("d", -1, d) And UCase$(CStr(lastWorkedSlot(nm))) = "N" And UCase$(slot) <> "N")
End Function

Private Sub UpdateConsec(ByVal nm As String, ByVal d As Date, ByVal consecCount As Object, ByVal lastWorkedDate As Object)
    If lastWorkedDate.Exists(nm) Then
        If lastWorkedDate(nm) = DateAdd("d", -1, d) Then
            consecCount(nm) = IIf(consecCount.Exists(nm), consecCount(nm) + 1, 1)
        Else
            consecCount(nm) = 1
        End If
    Else
        consecCount(nm) = 1
    End If
    lastWorkedDate(nm) = d
End Sub

Private Function AppendNote(ByVal notes As String, ByVal s As String) As String
    If Len(notes) = 0 Then AppendNote = s Else AppendNote = notes & " | " & s
End Function

Private Sub FormatShiftView(ByVal ws As Worksheet, ByVal startAddress As String)
    With ws.Range(startAddress).CurrentRegion
        .Columns.AutoFit
        .Borders.LineStyle = xlContinuous
        ' 未充足のメモを赤、部分充足を黄
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=ISNUMBER(SEARCH(""UNFILLED"", $" & Split(.Columns(.Columns.Count).Address, "$")(1) & "2))"
        .FormatConditions(1).Interior.Color = RGB(255, 220, 220)
        .FormatConditions.Add Type:=xlExpression, Formula1:="=ISNUMBER(SEARCH(""/"", $" & Split(.Columns(.Columns.Count).Address, "$")(1) & "2))"
        .FormatConditions(2).Interior.Color = RGB(255, 255, 200)
    End With
End Sub
VB

重要部分の深掘り

  • 公平性スコアの設計:「少ない人ほど優先＋週末重み」で偏りを抑えます。必要なら“直近の連続稼働ペナルティ”を加えるとさらに安定。
  • 夜勤翌日回避: 夜勤→翌日AM/PMの割り当てを禁止するだけで、過度な連続疲労を避けられます。
  • UNFILLEDマーキング: 人員不足はメモ列に集約し、後で手当（外部応援・シフト再配分）しやすくします。

例題の通し方：スタッフ3名＋月前半のニーズ＋希望から自動生成

ステップ

  • Staff: 山田(Manager,20,3,Y,1.2)、佐藤(Staff,18,3,Y,1.0)、田中(Staff,18,3,Y,1.0)
  • Needs: 1/1〜1/7のAM:Mgr1+Staff2, PM:Mgr1+Staff2, N:Mgr0+Staff0
  • Avail: 各人の可否（Y/N）を日付ごとに入力

実行

Sub Demo_Run()
    GenerateMonthlyShift 2026, 1
End Sub
VB

期待結果として、AM/PMの枠が役割人数分埋まり、埋まらない日は“UNFILLED”がNotesに出ます。夜勤ニーズが0のため、N列は空のままです。

落とし穴と対策：制約の順序・公平性・データ不備

よくある問題と対処

  • 制約チェックの順序が複雑:「希望→役割一致→拒否条件→公平性」の順に固定すると、ロジックが崩れません。
  • 連続勤務のカウントずれ: “前日勤務なら+1、離れたら1へリセット”を割り当て時に必ず更新。読む側で加算しない。
  • 可用性の欠損: Availにない、日付フォーマット違いは候補から外れる。CurrentRegionのデータ範囲を確認し、日付は“yyyy-mm-dd”で統一。
  • 役割不足で埋まらない: Needsが現実的かを先に検証（1枠につき候補人数が十分か）。不足日はメモに出るので、受入条件の緩和や外部応援を検討。

まとめ：可用性→制約→公平性の型で、壊れないシフト自動化を実現する

入力は役割別ニーズと希望をシンプルに。割り当ては“拒否条件で弾く→公平性で選ぶ”の一本化。不足はメモに集約し、再配分・応援の判断を早くします。

スポンサーリンク
タイトルとURLをコピーしました