Option Explicit
Const Week_str As String = "*,日,月,火,水,木,金,土"
Const Shift_str As String = "1,1,1,1,ﾔ,2,2,2,2,ﾔ,3,3,3,3,ﾔ,ﾔ"
Const A_stx As Long = 6         'Aグループの2020年1月1日のインデックス
Const B_stx As Long = 2         'Bグループの2020年1月1日のインデックス
Const C_stx As Long = 14        'Cグループの2020年1月1日のインデックス
Const D_stx As Long = 10        'Dグループの2020年1月1日のインデックス
Dim ws As Worksheet
Dim cs As Worksheet
Dim shift_p As Variant
Dim week_name As Variant
Dim dicT As Object          '祝日カレンダーの祝日を記憶
Public Sub シフト表作成()
    Dim yyyy As Long
    Dim mm As Long
    Dim maxrow As Long
    Dim wrow As Long
    Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    shift_p = Split(Shift_str, ",")
    week_name = Split(Week_str, ",")
    Set ws = Worksheets("シフト表")
    Set cs = Worksheets("祝日")
    yyyy = 0
    If IsNumeric(ws.Cells(1, "I").Value) = True Then
        If ws.Cells(1, "I").Value >= 2020 And ws.Cells(1, "I").Value <= 2099 Then
            yyyy = ws.Cells(1, "I").Value
        End If
    End If
    If yyyy = 0 Then
        MsgBox ("2020年～2099年を指定してください")
        Exit Sub
    End If
    maxrow = cs.Cells(Rows.Count, 1).End(xlUp).row    '最終行を求める
    '祝日カレンダーを記憶
    For wrow = 2 To maxrow
        dicT(cs.Cells(wrow, "A").Value) = True
    Next
    ws.Range("A3:AF87").ClearContents
    For mm = 1 To 12
        Call make_1month(yyyy, mm)
    Next
 
End Sub
'1カ月分のカレンダー作成
Private Sub make_1month(ByVal yyyy As Long, ByVal mm As Long)
    Dim diff As Long
    Dim aix As Long
    Dim bix As Long
    Dim cix As Long
    Dim dix As Long
    Dim dd As Long
    Dim wdate As Date
    Dim lastday As Long         '月末日
    Dim srow As Long            '開始行（曜日）
    Dim wx As Long
    Dim wcol As Long
    lastday = Day(DateSerial(yyyy, mm + 1, 0))
    diff = DateSerial(yyyy, mm, 1) - DateSerial(2020, 1, 1)
    aix = (diff + A_stx) Mod 16
    bix = (diff + B_stx) Mod 16
    cix = (diff + C_stx) Mod 16
    dix = (diff + D_stx) Mod 16
    srow = (mm - 1) * 7 + 3
    ws.Cells(srow, "A").Value = mm & "月"
    ws.Cells(srow + 2, "A").Value = "A"
    ws.Cells(srow + 3, "A").Value = "B"
    ws.Cells(srow + 4, "A").Value = "C"
    ws.Cells(srow + 5, "A").Value = "D"
 
    wdate = DateSerial(yyyy, mm, 1)
    '1～月末まで繰り返す
    For dd = 1 To lastday
        wx = Weekday(wdate, vbSunday)
        wcol = dd + 1
        ws.Cells(srow, wcol).Value = week_name(wx)          '曜日
        '祝日か日曜日なら赤
        ws.Cells(srow, wcol).Font.ColorIndex = xlAutomatic
        If dicT.exists(wdate) = True Or wx = 1 Then
            ws.Cells(srow, wcol).Font.Color = -16776961
            '土曜日なら青
        ElseIf wx = 7 Then
            ws.Cells(srow, wcol).Font.Color = -1003520
        End If
        ws.Cells(srow + 1, wcol).Value = dd & "日"          '日
        ws.Cells(srow + 2, wcol).Value = shift_p(aix)       'Aのシフト
        ws.Cells(srow + 3, wcol).Value = shift_p(bix)       'Bのシフト
        ws.Cells(srow + 4, wcol).Value = shift_p(cix)       'Cのシフト
        ws.Cells(srow + 5, wcol).Value = shift_p(dix)       'Dのシフト
        aix = next_shift(aix)
        bix = next_shift(bix)
        cix = next_shift(cix)
        dix = next_shift(dix)
        wdate = wdate + 1
    Next
End Sub
'次のシフトを取得
Private Function next_shift(ByVal shift_ix As Long) As Long
    next_shift = shift_ix + 1
    If next_shift > 15 Or next_shift < 0 Then
        next_shift = 0
    End If
End Function
 

T3B0aW9uIEV4cGxpY2l0CkNvbnN0IFdlZWtfc3RyIEFzIFN0cmluZyA9ICIqLOaXpSzmnIgs54GrLOawtCzmnKgs6YeRLOWcnyIKQ29uc3QgU2hpZnRfc3RyIEFzIFN0cmluZyA9ICIxLDEsMSwxLO++lCwyLDIsMiwyLO++lCwzLDMsMywzLO++lCzvvpQiCkNvbnN0IEFfc3R4IEFzIExvbmcgPSA2ICAgICAgICAgJ0HjgrDjg6vjg7zjg5fjga4yMDIw5bm0MeaciDHml6Xjga7jgqTjg7Pjg4fjg4Pjgq/jgrkKQ29uc3QgQl9zdHggQXMgTG9uZyA9IDIgICAgICAgICAnQuOCsOODq+ODvOODl+OBrjIwMjDlubQx5pyIMeaXpeOBruOCpOODs+ODh+ODg+OCr+OCuQpDb25zdCBDX3N0eCBBcyBMb25nID0gMTQgICAgICAgICdD44Kw44Or44O844OX44GuMjAyMOW5tDHmnIgx5pel44Gu44Kk44Oz44OH44OD44Kv44K5CkNvbnN0IERfc3R4IEFzIExvbmcgPSAxMCAgICAgICAgJ0TjgrDjg6vjg7zjg5fjga4yMDIw5bm0MeaciDHml6Xjga7jgqTjg7Pjg4fjg4Pjgq/jgrkKRGltIHdzIEFzIFdvcmtzaGVldApEaW0gY3MgQXMgV29ya3NoZWV0CkRpbSBzaGlmdF9wIEFzIFZhcmlhbnQKRGltIHdlZWtfbmFtZSBBcyBWYXJpYW50CkRpbSBkaWNUIEFzIE9iamVjdCAgICAgICAgICAn56Wd5pel44Kr44Os44Oz44OA44O844Gu56Wd5pel44KS6KiY5oa2ClB1YmxpYyBTdWIg44K344OV44OI6KGo5L2c5oiQKCkKICAgIERpbSB5eXl5IEFzIExvbmcKICAgIERpbSBtbSBBcyBMb25nCiAgICBEaW0gbWF4cm93IEFzIExvbmcKICAgIERpbSB3cm93IEFzIExvbmcKICAgIFNldCBkaWNUID0gQ3JlYXRlT2JqZWN0KCJTY3JpcHRpbmcuRGljdGlvbmFyeSIpICAgICcg6YCj5oOz6YWN5YiX44Gu5a6a576pCiAgICBzaGlmdF9wID0gU3BsaXQoU2hpZnRfc3RyLCAiLCIpCiAgICB3ZWVrX25hbWUgPSBTcGxpdChXZWVrX3N0ciwgIiwiKQogICAgU2V0IHdzID0gV29ya3NoZWV0cygi44K344OV44OI6KGoIikKICAgIFNldCBjcyA9IFdvcmtzaGVldHMoIuelneaXpSIpCiAgICB5eXl5ID0gMAogICAgSWYgSXNOdW1lcmljKHdzLkNlbGxzKDEsICJJIikuVmFsdWUpID0gVHJ1ZSBUaGVuCiAgICAgICAgSWYgd3MuQ2VsbHMoMSwgIkkiKS5WYWx1ZSA+PSAyMDIwIEFuZCB3cy5DZWxscygxLCAiSSIpLlZhbHVlIDw9IDIwOTkgVGhlbgogICAgICAgICAgICB5eXl5ID0gd3MuQ2VsbHMoMSwgIkkiKS5WYWx1ZQogICAgICAgIEVuZCBJZgogICAgRW5kIElmCiAgICBJZiB5eXl5ID0gMCBUaGVuCiAgICAgICAgTXNnQm94ICgiMjAyMOW5tO+9njIwOTnlubTjgpLmjIflrprjgZfjgabjgY/jgaDjgZXjgYQiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgIG1heHJvdyA9IGNzLkNlbGxzKFJvd3MuQ291bnQsIDEpLkVuZCh4bFVwKS5yb3cgICAgJ+acgOe1guihjOOCkuaxguOCgeOCiwogICAgJ+elneaXpeOCq+ODrOODs+ODgOODvOOCkuiomOaGtgogICAgRm9yIHdyb3cgPSAyIFRvIG1heHJvdwogICAgICAgIGRpY1QoY3MuQ2VsbHMod3JvdywgIkEiKS5WYWx1ZSkgPSBUcnVlCiAgICBOZXh0CiAgICB3cy5SYW5nZSgiQTM6QUY4NyIpLkNsZWFyQ29udGVudHMKICAgIEZvciBtbSA9IDEgVG8gMTIKICAgICAgICBDYWxsIG1ha2VfMW1vbnRoKHl5eXksIG1tKQogICAgTmV4dAoKRW5kIFN1YgonMeOCq+aciOWIhuOBruOCq+ODrOODs+ODgOODvOS9nOaIkApQcml2YXRlIFN1YiBtYWtlXzFtb250aChCeVZhbCB5eXl5IEFzIExvbmcsIEJ5VmFsIG1tIEFzIExvbmcpCiAgICBEaW0gZGlmZiBBcyBMb25nCiAgICBEaW0gYWl4IEFzIExvbmcKICAgIERpbSBiaXggQXMgTG9uZwogICAgRGltIGNpeCBBcyBMb25nCiAgICBEaW0gZGl4IEFzIExvbmcKICAgIERpbSBkZCBBcyBMb25nCiAgICBEaW0gd2RhdGUgQXMgRGF0ZQogICAgRGltIGxhc3RkYXkgQXMgTG9uZyAgICAgICAgICfmnIjmnKvml6UKICAgIERpbSBzcm93IEFzIExvbmcgICAgICAgICAgICAn6ZaL5aeL6KGM77yI5puc5pel77yJCiAgICBEaW0gd3ggQXMgTG9uZwogICAgRGltIHdjb2wgQXMgTG9uZwogICAgbGFzdGRheSA9IERheShEYXRlU2VyaWFsKHl5eXksIG1tICsgMSwgMCkpCiAgICBkaWZmID0gRGF0ZVNlcmlhbCh5eXl5LCBtbSwgMSkgLSBEYXRlU2VyaWFsKDIwMjAsIDEsIDEpCiAgICBhaXggPSAoZGlmZiArIEFfc3R4KSBNb2QgMTYKICAgIGJpeCA9IChkaWZmICsgQl9zdHgpIE1vZCAxNgogICAgY2l4ID0gKGRpZmYgKyBDX3N0eCkgTW9kIDE2CiAgICBkaXggPSAoZGlmZiArIERfc3R4KSBNb2QgMTYKICAgIHNyb3cgPSAobW0gLSAxKSAqIDcgKyAzCiAgICB3cy5DZWxscyhzcm93LCAiQSIpLlZhbHVlID0gbW0gJiAi5pyIIgogICAgd3MuQ2VsbHMoc3JvdyArIDIsICJBIikuVmFsdWUgPSAiQSIKICAgIHdzLkNlbGxzKHNyb3cgKyAzLCAiQSIpLlZhbHVlID0gIkIiCiAgICB3cy5DZWxscyhzcm93ICsgNCwgIkEiKS5WYWx1ZSA9ICJDIgogICAgd3MuQ2VsbHMoc3JvdyArIDUsICJBIikuVmFsdWUgPSAiRCIKCiAgICB3ZGF0ZSA9IERhdGVTZXJpYWwoeXl5eSwgbW0sIDEpCiAgICAnMe+9nuaciOacq+OBvuOBp+e5sOOCiui/lOOBmQogICAgRm9yIGRkID0gMSBUbyBsYXN0ZGF5CiAgICAgICAgd3ggPSBXZWVrZGF5KHdkYXRlLCB2YlN1bmRheSkKICAgICAgICB3Y29sID0gZGQgKyAxCiAgICAgICAgd3MuQ2VsbHMoc3Jvdywgd2NvbCkuVmFsdWUgPSB3ZWVrX25hbWUod3gpICAgICAgICAgICfmm5zml6UKICAgICAgICAn56Wd5pel44GL5pel5puc5pel44Gq44KJ6LWkCiAgICAgICAgd3MuQ2VsbHMoc3Jvdywgd2NvbCkuRm9udC5Db2xvckluZGV4ID0geGxBdXRvbWF0aWMKICAgICAgICBJZiBkaWNULmV4aXN0cyh3ZGF0ZSkgPSBUcnVlIE9yIHd4ID0gMSBUaGVuCiAgICAgICAgICAgIHdzLkNlbGxzKHNyb3csIHdjb2wpLkZvbnQuQ29sb3IgPSAtMTY3NzY5NjEKICAgICAgICAgICAgJ+Wcn+abnOaXpeOBquOCiemdkgogICAgICAgIEVsc2VJZiB3eCA9IDcgVGhlbgogICAgICAgICAgICB3cy5DZWxscyhzcm93LCB3Y29sKS5Gb250LkNvbG9yID0gLTEwMDM1MjAKICAgICAgICBFbmQgSWYKICAgICAgICB3cy5DZWxscyhzcm93ICsgMSwgd2NvbCkuVmFsdWUgPSBkZCAmICLml6UiICAgICAgICAgICfml6UKICAgICAgICB3cy5DZWxscyhzcm93ICsgMiwgd2NvbCkuVmFsdWUgPSBzaGlmdF9wKGFpeCkgICAgICAgJ0Hjga7jgrfjg5Xjg4gKICAgICAgICB3cy5DZWxscyhzcm93ICsgMywgd2NvbCkuVmFsdWUgPSBzaGlmdF9wKGJpeCkgICAgICAgJ0Ljga7jgrfjg5Xjg4gKICAgICAgICB3cy5DZWxscyhzcm93ICsgNCwgd2NvbCkuVmFsdWUgPSBzaGlmdF9wKGNpeCkgICAgICAgJ0Pjga7jgrfjg5Xjg4gKICAgICAgICB3cy5DZWxscyhzcm93ICsgNSwgd2NvbCkuVmFsdWUgPSBzaGlmdF9wKGRpeCkgICAgICAgJ0Tjga7jgrfjg5Xjg4gKICAgICAgICBhaXggPSBuZXh0X3NoaWZ0KGFpeCkKICAgICAgICBiaXggPSBuZXh0X3NoaWZ0KGJpeCkKICAgICAgICBjaXggPSBuZXh0X3NoaWZ0KGNpeCkKICAgICAgICBkaXggPSBuZXh0X3NoaWZ0KGRpeCkKICAgICAgICB3ZGF0ZSA9IHdkYXRlICsgMQogICAgTmV4dApFbmQgU3ViCifmrKHjga7jgrfjg5Xjg4jjgpLlj5blvpcKUHJpdmF0ZSBGdW5jdGlvbiBuZXh0X3NoaWZ0KEJ5VmFsIHNoaWZ0X2l4IEFzIExvbmcpIEFzIExvbmcKICAgIG5leHRfc2hpZnQgPSBzaGlmdF9peCArIDEKICAgIElmIG5leHRfc2hpZnQgPiAxNSBPciBuZXh0X3NoaWZ0IDwgMCBUaGVuCiAgICAgICAgbmV4dF9zaGlmdCA9IDAKICAgIEVuZCBJZgpFbmQgRnVuY3Rpb24K