Option Explicit
 
    Dim sh1 As Worksheet
    Dim dicT As Object      '連想配列（祝日）
    Dim ro_person_tbl As Variant
    Dim hl_person_tbl As Variant
    Dim ro_sx As Long
    Dim hl_sx As Long
    Dim sdate As Date
 
Public Sub 当番表作成()
    Dim maxrow As Long
    Dim wrow As Long
    Dim sh2 As Worksheet
    Dim s_year As Variant
    Dim ro_type As String
    Dim ro_tbl As Variant
    Dim hl_tbl As Variant
    Dim ro_ix As Long
    Dim ro_sub_no As Variant
    Dim hl_sub_no As Variant
    Dim mm As Long
    Dim i As Long
    ro_tbl = Array("AABCDEF", "ABBCDEF", "ABCCDEF", "ABCDDEF", "ABCDEEF", "ABCDEFF", "ABCDEF")
    hl_tbl = Array("EACBEDF")
    Set dicT = CreateObject("Scripting.Dictionary")
    Set sh1 = Worksheets("当番表")
    Set sh2 = Worksheets("祝日")
    '祝日の記憶
    maxrow = sh2.Cells(Rows.count, 1).End(xlUp).row    '最大行取得
    For wrow = 2 To maxrow
        dicT(sh2.Cells(wrow, 1).value) = True
    Next
    s_year = sh1.Cells(1, "D").value
    If s_year < 2020 Or s_year > 2099 Then
        sh1.Cells(1, "D").Select
        MsgBox ("指定年エラー")
        Exit Sub
    End If
    sh1.Cells(1, "K").Validation.Delete
    sh1.Cells(1, "K").Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=Join(ro_tbl, ",")
    sh1.Cells(2, "K").value = hl_tbl(0)
    ro_type = sh1.Cells(1, "K").value
    ro_ix = GetRoIx(ro_type, ro_tbl)
    If ro_ix < 0 Then
        sh1.Cells(1, "K").Select
        MsgBox ("月～土ローテーションタイプエラー")
        Exit Sub
    End If
    ro_sub_no = sh1.Cells(1, "M").value
    hl_sub_no = sh1.Cells(2, "M").value
    If ro_sub_no < 1 Or ro_sub_no > Len(ro_type) Then
        sh1.Cells(1, "M").Select
        MsgBox ("月～土ローテーションタイプ内番目エラー")
        Exit Sub
    End If
    If hl_sub_no < 1 Or hl_sub_no > Len(hl_tbl(0)) Then
        sh1.Cells(2, "M").Select
        MsgBox ("祝祭日ローテーションタイプ内番目エラー")
        Exit Sub
    End If
    ro_person_tbl = create_person_table(ro_tbl)
    hl_person_tbl = create_person_table(hl_tbl)
    '開始インデックスの設定
    ro_sx = ro_ix * 7 + ro_sub_no - 1
    hl_sx = hl_sub_no - 1
    '4行目以降をクリア
    sh1.Rows("4:" & Rows.count).ClearContents
    sdate = DateSerial(s_year, 1, 1)
    '1～１２月の当番表作成
    For mm = 1 To 12
        Call make_1month(mm)
    Next
    MsgBox ("完了")
End Sub
'1カ月分の当番表作成
Private Sub make_1month(ByVal mm As Long)
    Dim wrow As Long
    Dim wcol As Long
    Dim lastday As Long
    Dim dd As Long
    Dim week As Long
    wrow = (mm - 1) * 4 + 4
    sh1.Cells(wrow, 1).value = mm & "月"
    lastday = Day(DateSerial(year(sdate), mm + 1, 0))
    sh1.Range("B" & wrow + 1 & ":AF" & wrow + 1).Font.ColorIndex = xlAutomatic
    For dd = 1 To lastday
        wcol = dd + 1
        'sh1.Cells(wrow, wcol).value = sdate
        sh1.Cells(wrow, wcol).value = Day(sdate) & "日"
        week = Weekday(sdate)
        sh1.Cells(wrow + 1, wcol).value = WeekdayName(week, True)
        If week = 1 Or dicT(sdate) = True Then
            sh1.Cells(wrow + 1, wcol).Font.Color = -16776961
        End If
        If week = 1 Or dicT(sdate) = True Then
            sh1.Cells(wrow + 2, wcol).value = getPerson(hl_sx, hl_person_tbl)
        Else
            sh1.Cells(wrow + 2, wcol).value = getPerson(ro_sx, ro_person_tbl)
        End If
        sdate = sdate + 1
    Next
End Sub
'当番取得
Private Function getPerson(ByRef ix As Long, ByRef person_tbl As Variant)
    getPerson = person_tbl(ix)
    ix = ix + 1
    If ix > UBound(person_tbl) Then
        ix = 0
    End If
End Function
'ローテーション・インデックス取得
Private Function GetRoIx(ByVal ro_type As String, ByVal ro_tbl As Variant) As Long
    Dim i As Long
    GetRoIx = -1
    For i = 0 To UBound(ro_tbl)
        If ro_type = ro_tbl(i) Then
            GetRoIx = i
            Exit Function
        End If
    Next
End Function
'個人の通しテーブル作成
Private Function create_person_table(ByVal rotbl As Variant) As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim otbl As Variant
    Dim str As String
    otbl = Array("")
    k = 0
    For i = 0 To UBound(rotbl)
        str = rotbl(i)
        For j = 1 To Len(str)
            ReDim Preserve otbl(k)
            otbl(k) = Mid(str, j, 1)
            k = k + 1
        Next
    Next
    create_person_table = otbl
End Function

T3B0aW9uIEV4cGxpY2l0CgogICAgRGltIHNoMSBBcyBXb3Jrc2hlZXQKICAgIERpbSBkaWNUIEFzIE9iamVjdCAgICAgICfpgKPmg7PphY3liJfvvIjnpZ3ml6XvvIkKICAgIERpbSByb19wZXJzb25fdGJsIEFzIFZhcmlhbnQKICAgIERpbSBobF9wZXJzb25fdGJsIEFzIFZhcmlhbnQKICAgIERpbSByb19zeCBBcyBMb25nCiAgICBEaW0gaGxfc3ggQXMgTG9uZwogICAgRGltIHNkYXRlIEFzIERhdGUKClB1YmxpYyBTdWIg5b2T55Wq6KGo5L2c5oiQKCkKICAgIERpbSBtYXhyb3cgQXMgTG9uZwogICAgRGltIHdyb3cgQXMgTG9uZwogICAgRGltIHNoMiBBcyBXb3Jrc2hlZXQKICAgIERpbSBzX3llYXIgQXMgVmFyaWFudAogICAgRGltIHJvX3R5cGUgQXMgU3RyaW5nCiAgICBEaW0gcm9fdGJsIEFzIFZhcmlhbnQKICAgIERpbSBobF90YmwgQXMgVmFyaWFudAogICAgRGltIHJvX2l4IEFzIExvbmcKICAgIERpbSByb19zdWJfbm8gQXMgVmFyaWFudAogICAgRGltIGhsX3N1Yl9ubyBBcyBWYXJpYW50CiAgICBEaW0gbW0gQXMgTG9uZwogICAgRGltIGkgQXMgTG9uZwogICAgcm9fdGJsID0gQXJyYXkoIkFBQkNERUYiLCAiQUJCQ0RFRiIsICJBQkNDREVGIiwgIkFCQ0RERUYiLCAiQUJDREVFRiIsICJBQkNERUZGIiwgIkFCQ0RFRiIpCiAgICBobF90YmwgPSBBcnJheSgiRUFDQkVERiIpCiAgICBTZXQgZGljVCA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKQogICAgU2V0IHNoMSA9IFdvcmtzaGVldHMoIuW9k+eVquihqCIpCiAgICBTZXQgc2gyID0gV29ya3NoZWV0cygi56Wd5pelIikKICAgICfnpZ3ml6Xjga7oqJjmhrYKICAgIG1heHJvdyA9IHNoMi5DZWxscyhSb3dzLmNvdW50LCAxKS5FbmQoeGxVcCkucm93ICAgICfmnIDlpKfooYzlj5blvpcKICAgIEZvciB3cm93ID0gMiBUbyBtYXhyb3cKICAgICAgICBkaWNUKHNoMi5DZWxscyh3cm93LCAxKS52YWx1ZSkgPSBUcnVlCiAgICBOZXh0CiAgICBzX3llYXIgPSBzaDEuQ2VsbHMoMSwgIkQiKS52YWx1ZQogICAgSWYgc195ZWFyIDwgMjAyMCBPciBzX3llYXIgPiAyMDk5IFRoZW4KICAgICAgICBzaDEuQ2VsbHMoMSwgIkQiKS5TZWxlY3QKICAgICAgICBNc2dCb3ggKCLmjIflrprlubTjgqjjg6njg7wiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgIHNoMS5DZWxscygxLCAiSyIpLlZhbGlkYXRpb24uRGVsZXRlCiAgICBzaDEuQ2VsbHMoMSwgIksiKS5WYWxpZGF0aW9uLkFkZCBUeXBlOj14bFZhbGlkYXRlTGlzdCwgT3BlcmF0b3I6PXhsQmV0d2VlbiwgRm9ybXVsYTE6PUpvaW4ocm9fdGJsLCAiLCIpCiAgICBzaDEuQ2VsbHMoMiwgIksiKS52YWx1ZSA9IGhsX3RibCgwKQogICAgcm9fdHlwZSA9IHNoMS5DZWxscygxLCAiSyIpLnZhbHVlCiAgICByb19peCA9IEdldFJvSXgocm9fdHlwZSwgcm9fdGJsKQogICAgSWYgcm9faXggPCAwIFRoZW4KICAgICAgICBzaDEuQ2VsbHMoMSwgIksiKS5TZWxlY3QKICAgICAgICBNc2dCb3ggKCLmnIjvvZ7lnJ/jg63jg7zjg4bjg7zjgrfjg6fjg7Pjgr/jgqTjg5fjgqjjg6njg7wiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgIHJvX3N1Yl9ubyA9IHNoMS5DZWxscygxLCAiTSIpLnZhbHVlCiAgICBobF9zdWJfbm8gPSBzaDEuQ2VsbHMoMiwgIk0iKS52YWx1ZQogICAgSWYgcm9fc3ViX25vIDwgMSBPciByb19zdWJfbm8gPiBMZW4ocm9fdHlwZSkgVGhlbgogICAgICAgIHNoMS5DZWxscygxLCAiTSIpLlNlbGVjdAogICAgICAgIE1zZ0JveCAoIuaciO+9nuWcn+ODreODvOODhuODvOOCt+ODp+ODs+OCv+OCpOODl+WGheeVquebruOCqOODqeODvCIpCiAgICAgICAgRXhpdCBTdWIKICAgIEVuZCBJZgogICAgSWYgaGxfc3ViX25vIDwgMSBPciBobF9zdWJfbm8gPiBMZW4oaGxfdGJsKDApKSBUaGVuCiAgICAgICAgc2gxLkNlbGxzKDIsICJNIikuU2VsZWN0CiAgICAgICAgTXNnQm94ICgi56Wd56Wt5pel44Ot44O844OG44O844K344On44Oz44K/44Kk44OX5YaF55Wq55uu44Ko44Op44O8IikKICAgICAgICBFeGl0IFN1YgogICAgRW5kIElmCiAgICByb19wZXJzb25fdGJsID0gY3JlYXRlX3BlcnNvbl90YWJsZShyb190YmwpCiAgICBobF9wZXJzb25fdGJsID0gY3JlYXRlX3BlcnNvbl90YWJsZShobF90YmwpCiAgICAn6ZaL5aeL44Kk44Oz44OH44OD44Kv44K544Gu6Kit5a6aCiAgICByb19zeCA9IHJvX2l4ICogNyArIHJvX3N1Yl9ubyAtIDEKICAgIGhsX3N4ID0gaGxfc3ViX25vIC0gMQogICAgJzTooYznm67ku6XpmY3jgpLjgq/jg6rjgqIKICAgIHNoMS5Sb3dzKCI0OiIgJiBSb3dzLmNvdW50KS5DbGVhckNvbnRlbnRzCiAgICBzZGF0ZSA9IERhdGVTZXJpYWwoc195ZWFyLCAxLCAxKQogICAgJzHvvZ7vvJHvvJLmnIjjga7lvZPnlarooajkvZzmiJAKICAgIEZvciBtbSA9IDEgVG8gMTIKICAgICAgICBDYWxsIG1ha2VfMW1vbnRoKG1tKQogICAgTmV4dAogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1YgonMeOCq+aciOWIhuOBruW9k+eVquihqOS9nOaIkApQcml2YXRlIFN1YiBtYWtlXzFtb250aChCeVZhbCBtbSBBcyBMb25nKQogICAgRGltIHdyb3cgQXMgTG9uZwogICAgRGltIHdjb2wgQXMgTG9uZwogICAgRGltIGxhc3RkYXkgQXMgTG9uZwogICAgRGltIGRkIEFzIExvbmcKICAgIERpbSB3ZWVrIEFzIExvbmcKICAgIHdyb3cgPSAobW0gLSAxKSAqIDQgKyA0CiAgICBzaDEuQ2VsbHMod3JvdywgMSkudmFsdWUgPSBtbSAmICLmnIgiCiAgICBsYXN0ZGF5ID0gRGF5KERhdGVTZXJpYWwoeWVhcihzZGF0ZSksIG1tICsgMSwgMCkpCiAgICBzaDEuUmFuZ2UoIkIiICYgd3JvdyArIDEgJiAiOkFGIiAmIHdyb3cgKyAxKS5Gb250LkNvbG9ySW5kZXggPSB4bEF1dG9tYXRpYwogICAgRm9yIGRkID0gMSBUbyBsYXN0ZGF5CiAgICAgICAgd2NvbCA9IGRkICsgMQogICAgICAgICdzaDEuQ2VsbHMod3Jvdywgd2NvbCkudmFsdWUgPSBzZGF0ZQogICAgICAgIHNoMS5DZWxscyh3cm93LCB3Y29sKS52YWx1ZSA9IERheShzZGF0ZSkgJiAi5pelIgogICAgICAgIHdlZWsgPSBXZWVrZGF5KHNkYXRlKQogICAgICAgIHNoMS5DZWxscyh3cm93ICsgMSwgd2NvbCkudmFsdWUgPSBXZWVrZGF5TmFtZSh3ZWVrLCBUcnVlKQogICAgICAgIElmIHdlZWsgPSAxIE9yIGRpY1Qoc2RhdGUpID0gVHJ1ZSBUaGVuCiAgICAgICAgICAgIHNoMS5DZWxscyh3cm93ICsgMSwgd2NvbCkuRm9udC5Db2xvciA9IC0xNjc3Njk2MQogICAgICAgIEVuZCBJZgogICAgICAgIElmIHdlZWsgPSAxIE9yIGRpY1Qoc2RhdGUpID0gVHJ1ZSBUaGVuCiAgICAgICAgICAgIHNoMS5DZWxscyh3cm93ICsgMiwgd2NvbCkudmFsdWUgPSBnZXRQZXJzb24oaGxfc3gsIGhsX3BlcnNvbl90YmwpCiAgICAgICAgRWxzZQogICAgICAgICAgICBzaDEuQ2VsbHMod3JvdyArIDIsIHdjb2wpLnZhbHVlID0gZ2V0UGVyc29uKHJvX3N4LCByb19wZXJzb25fdGJsKQogICAgICAgIEVuZCBJZgogICAgICAgIHNkYXRlID0gc2RhdGUgKyAxCiAgICBOZXh0CkVuZCBTdWIKJ+W9k+eVquWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIGdldFBlcnNvbihCeVJlZiBpeCBBcyBMb25nLCBCeVJlZiBwZXJzb25fdGJsIEFzIFZhcmlhbnQpCiAgICBnZXRQZXJzb24gPSBwZXJzb25fdGJsKGl4KQogICAgaXggPSBpeCArIDEKICAgIElmIGl4ID4gVUJvdW5kKHBlcnNvbl90YmwpIFRoZW4KICAgICAgICBpeCA9IDAKICAgIEVuZCBJZgpFbmQgRnVuY3Rpb24KJ+ODreODvOODhuODvOOCt+ODp+ODs+ODu+OCpOODs+ODh+ODg+OCr+OCueWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIEdldFJvSXgoQnlWYWwgcm9fdHlwZSBBcyBTdHJpbmcsIEJ5VmFsIHJvX3RibCBBcyBWYXJpYW50KSBBcyBMb25nCiAgICBEaW0gaSBBcyBMb25nCiAgICBHZXRSb0l4ID0gLTEKICAgIEZvciBpID0gMCBUbyBVQm91bmQocm9fdGJsKQogICAgICAgIElmIHJvX3R5cGUgPSByb190YmwoaSkgVGhlbgogICAgICAgICAgICBHZXRSb0l4ID0gaQogICAgICAgICAgICBFeGl0IEZ1bmN0aW9uCiAgICAgICAgRW5kIElmCiAgICBOZXh0CkVuZCBGdW5jdGlvbgon5YCL5Lq644Gu6YCa44GX44OG44O844OW44Or5L2c5oiQClByaXZhdGUgRnVuY3Rpb24gY3JlYXRlX3BlcnNvbl90YWJsZShCeVZhbCByb3RibCBBcyBWYXJpYW50KSBBcyBWYXJpYW50CiAgICBEaW0gaSBBcyBMb25nCiAgICBEaW0gaiBBcyBMb25nCiAgICBEaW0gayBBcyBMb25nCiAgICBEaW0gb3RibCBBcyBWYXJpYW50CiAgICBEaW0gc3RyIEFzIFN0cmluZwogICAgb3RibCA9IEFycmF5KCIiKQogICAgayA9IDAKICAgIEZvciBpID0gMCBUbyBVQm91bmQocm90YmwpCiAgICAgICAgc3RyID0gcm90YmwoaSkKICAgICAgICBGb3IgaiA9IDEgVG8gTGVuKHN0cikKICAgICAgICAgICAgUmVEaW0gUHJlc2VydmUgb3RibChrKQogICAgICAgICAgICBvdGJsKGspID0gTWlkKHN0ciwgaiwgMSkKICAgICAgICAgICAgayA9IGsgKyAxCiAgICAgICAgTmV4dAogICAgTmV4dAogICAgY3JlYXRlX3BlcnNvbl90YWJsZSA9IG90YmwKRW5kIEZ1bmN0aW9u