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_pos 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, ro_pos)
    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_pos + 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, ByRef ro_pos As Long) As Long
    Dim i As Long
    GetRoIx = -1
    ro_pos = 0
    For i = 0 To UBound(ro_tbl)
        If ro_type = ro_tbl(i) Then
            GetRoIx = i
            Exit Function
        End If
        ro_pos = ro_pos + Len(ro_tbl(i))
    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
 

T3B0aW9uIEV4cGxpY2l0CgogICAgRGltIHNoMSBBcyBXb3Jrc2hlZXQKICAgIERpbSBkaWNUIEFzIE9iamVjdCAgICAgICfpgKPmg7PphY3liJfvvIjnpZ3ml6XvvIkKICAgIERpbSByb19wZXJzb25fdGJsIEFzIFZhcmlhbnQKICAgIERpbSBobF9wZXJzb25fdGJsIEFzIFZhcmlhbnQKICAgIERpbSByb19zeCBBcyBMb25nCiAgICBEaW0gaGxfc3ggQXMgTG9uZwogICAgRGltIHNkYXRlIEFzIERhdGUKClB1YmxpYyBTdWIg5b2T55Wq6KGo5L2c5oiQKCkKICAgIERpbSBtYXhyb3cgQXMgTG9uZwogICAgRGltIHdSb3cgQXMgTG9uZwogICAgRGltIHNoMiBBcyBXb3Jrc2hlZXQKICAgIERpbSBzX3llYXIgQXMgVmFyaWFudAogICAgRGltIHJvX3R5cGUgQXMgU3RyaW5nCiAgICBEaW0gcm9fdGJsIEFzIFZhcmlhbnQKICAgIERpbSBobF90YmwgQXMgVmFyaWFudAogICAgRGltIHJvX2l4IEFzIExvbmcKICAgIERpbSByb19wb3MgQXMgTG9uZwogICAgRGltIHJvX3N1Yl9ubyBBcyBWYXJpYW50CiAgICBEaW0gaGxfc3ViX25vIEFzIFZhcmlhbnQKICAgIERpbSBtbSBBcyBMb25nCiAgICBEaW0gaSBBcyBMb25nCiAgICByb190YmwgPSBBcnJheSgiQUFCQ0RFRiIsICJBQkJDREVGIiwgIkFCQ0NERUYiLCAiQUJDRERFRiIsICJBQkNERUVGIiwgIkFCQ0RFRkYiLCAiQUJDREVGIikKICAgIGhsX3RibCA9IEFycmF5KCJFQUNCRURGIikKICAgIFNldCBkaWNUID0gQ3JlYXRlT2JqZWN0KCJTY3JpcHRpbmcuRGljdGlvbmFyeSIpCiAgICBTZXQgc2gxID0gV29ya3NoZWV0cygi5b2T55Wq6KGoIikKICAgIFNldCBzaDIgPSBXb3Jrc2hlZXRzKCLnpZ3ml6UiKQogICAgJ+elneaXpeOBruiomOaGtgogICAgbWF4cm93ID0gc2gyLkNlbGxzKFJvd3MuY291bnQsIDEpLkVuZCh4bFVwKS5Sb3cgICAgJ+acgOWkp+ihjOWPluW+lwogICAgRm9yIHdSb3cgPSAyIFRvIG1heHJvdwogICAgICAgIGRpY1Qoc2gyLkNlbGxzKHdSb3csIDEpLnZhbHVlKSA9IFRydWUKICAgIE5leHQKICAgIHNfeWVhciA9IHNoMS5DZWxscygxLCAiRCIpLnZhbHVlCiAgICBJZiBzX3llYXIgPCAyMDIwIE9yIHNfeWVhciA+IDIwOTkgVGhlbgogICAgICAgIHNoMS5DZWxscygxLCAiRCIpLlNlbGVjdAogICAgICAgIE1zZ0JveCAoIuaMh+WumuW5tOOCqOODqeODvCIpCiAgICAgICAgRXhpdCBTdWIKICAgIEVuZCBJZgogICAgc2gxLkNlbGxzKDEsICJLIikuVmFsaWRhdGlvbi5EZWxldGUKICAgIHNoMS5DZWxscygxLCAiSyIpLlZhbGlkYXRpb24uQWRkIFR5cGU6PXhsVmFsaWRhdGVMaXN0LCBPcGVyYXRvcjo9eGxCZXR3ZWVuLCBGb3JtdWxhMTo9Sm9pbihyb190YmwsICIsIikKICAgIHNoMS5DZWxscygyLCAiSyIpLnZhbHVlID0gaGxfdGJsKDApCiAgICByb190eXBlID0gc2gxLkNlbGxzKDEsICJLIikudmFsdWUKICAgIHJvX2l4ID0gR2V0Um9JeChyb190eXBlLCByb190YmwsIHJvX3BvcykKICAgIElmIHJvX2l4IDwgMCBUaGVuCiAgICAgICAgc2gxLkNlbGxzKDEsICJLIikuU2VsZWN0CiAgICAgICAgTXNnQm94ICgi5pyI772e5Zyf44Ot44O844OG44O844K344On44Oz44K/44Kk44OX44Ko44Op44O8IikKICAgICAgICBFeGl0IFN1YgogICAgRW5kIElmCiAgICByb19zdWJfbm8gPSBzaDEuQ2VsbHMoMSwgIk0iKS52YWx1ZQogICAgaGxfc3ViX25vID0gc2gxLkNlbGxzKDIsICJNIikudmFsdWUKICAgIElmIHJvX3N1Yl9ubyA8IDEgT3Igcm9fc3ViX25vID4gTGVuKHJvX3R5cGUpIFRoZW4KICAgICAgICBzaDEuQ2VsbHMoMSwgIk0iKS5TZWxlY3QKICAgICAgICBNc2dCb3ggKCLmnIjvvZ7lnJ/jg63jg7zjg4bjg7zjgrfjg6fjg7Pjgr/jgqTjg5flhoXnlarnm67jgqjjg6njg7wiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgIElmIGhsX3N1Yl9ubyA8IDEgT3IgaGxfc3ViX25vID4gTGVuKGhsX3RibCgwKSkgVGhlbgogICAgICAgIHNoMS5DZWxscygyLCAiTSIpLlNlbGVjdAogICAgICAgIE1zZ0JveCAoIuelneelreaXpeODreODvOODhuODvOOCt+ODp+ODs+OCv+OCpOODl+WGheeVquebruOCqOODqeODvCIpCiAgICAgICAgRXhpdCBTdWIKICAgIEVuZCBJZgogICAgcm9fcGVyc29uX3RibCA9IGNyZWF0ZV9wZXJzb25fdGFibGUocm9fdGJsKQogICAgaGxfcGVyc29uX3RibCA9IGNyZWF0ZV9wZXJzb25fdGFibGUoaGxfdGJsKQogICAgJ+mWi+Wni+OCpOODs+ODh+ODg+OCr+OCueOBruioreWumgogICAgcm9fc3ggPSByb19wb3MgKyByb19zdWJfbm8gLSAxCiAgICBobF9zeCA9IGhsX3N1Yl9ubyAtIDEKICAgICc06KGM55uu5Lul6ZmN44KS44Kv44Oq44KiCiAgICBzaDEuUm93cygiNDoiICYgUm93cy5jb3VudCkuQ2xlYXJDb250ZW50cwogICAgc2RhdGUgPSBEYXRlU2VyaWFsKHNfeWVhciwgMSwgMSkKICAgICcx772e77yR77yS5pyI44Gu5b2T55Wq6KGo5L2c5oiQCiAgICBGb3IgbW0gPSAxIFRvIDEyCiAgICAgICAgQ2FsbCBtYWtlXzFtb250aChtbSkKICAgIE5leHQKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIKJzHjgqvmnIjliIbjga7lvZPnlarooajkvZzmiJAKUHJpdmF0ZSBTdWIgbWFrZV8xbW9udGgoQnlWYWwgbW0gQXMgTG9uZykKICAgIERpbSB3Um93IEFzIExvbmcKICAgIERpbSB3Y29sIEFzIExvbmcKICAgIERpbSBsYXN0ZGF5IEFzIExvbmcKICAgIERpbSBkZCBBcyBMb25nCiAgICBEaW0gd2VlayBBcyBMb25nCiAgICB3Um93ID0gKG1tIC0gMSkgKiA0ICsgNAogICAgc2gxLkNlbGxzKHdSb3csIDEpLnZhbHVlID0gbW0gJiAi5pyIIgogICAgbGFzdGRheSA9IERheShEYXRlU2VyaWFsKHllYXIoc2RhdGUpLCBtbSArIDEsIDApKQogICAgc2gxLlJhbmdlKCJCIiAmIHdSb3cgKyAxICYgIjpBRiIgJiB3Um93ICsgMSkuRm9udC5Db2xvckluZGV4ID0geGxBdXRvbWF0aWMKICAgIEZvciBkZCA9IDEgVG8gbGFzdGRheQogICAgICAgIHdjb2wgPSBkZCArIDEKICAgICAgICAnc2gxLkNlbGxzKHdyb3csIHdjb2wpLnZhbHVlID0gc2RhdGUKICAgICAgICBzaDEuQ2VsbHMod1Jvdywgd2NvbCkudmFsdWUgPSBEYXkoc2RhdGUpICYgIuaXpSIKICAgICAgICB3ZWVrID0gV2Vla2RheShzZGF0ZSkKICAgICAgICBzaDEuQ2VsbHMod1JvdyArIDEsIHdjb2wpLnZhbHVlID0gV2Vla2RheU5hbWUod2VlaywgVHJ1ZSkKICAgICAgICBJZiB3ZWVrID0gMSBPciBkaWNUKHNkYXRlKSA9IFRydWUgVGhlbgogICAgICAgICAgICBzaDEuQ2VsbHMod1JvdyArIDEsIHdjb2wpLkZvbnQuQ29sb3IgPSAtMTY3NzY5NjEKICAgICAgICBFbmQgSWYKICAgICAgICBJZiB3ZWVrID0gMSBPciBkaWNUKHNkYXRlKSA9IFRydWUgVGhlbgogICAgICAgICAgICBzaDEuQ2VsbHMod1JvdyArIDIsIHdjb2wpLnZhbHVlID0gZ2V0UGVyc29uKGhsX3N4LCBobF9wZXJzb25fdGJsKQogICAgICAgIEVsc2UKICAgICAgICAgICAgc2gxLkNlbGxzKHdSb3cgKyAyLCB3Y29sKS52YWx1ZSA9IGdldFBlcnNvbihyb19zeCwgcm9fcGVyc29uX3RibCkKICAgICAgICBFbmQgSWYKICAgICAgICBzZGF0ZSA9IHNkYXRlICsgMQogICAgTmV4dApFbmQgU3ViCiflvZPnlarlj5blvpcKUHJpdmF0ZSBGdW5jdGlvbiBnZXRQZXJzb24oQnlSZWYgaXggQXMgTG9uZywgQnlSZWYgcGVyc29uX3RibCBBcyBWYXJpYW50KQogICAgZ2V0UGVyc29uID0gcGVyc29uX3RibChpeCkKICAgIGl4ID0gaXggKyAxCiAgICBJZiBpeCA+IFVCb3VuZChwZXJzb25fdGJsKSBUaGVuCiAgICAgICAgaXggPSAwCiAgICBFbmQgSWYKRW5kIEZ1bmN0aW9uCifjg63jg7zjg4bjg7zjgrfjg6fjg7Pjg7vjgqTjg7Pjg4fjg4Pjgq/jgrnlj5blvpcKUHJpdmF0ZSBGdW5jdGlvbiBHZXRSb0l4KEJ5VmFsIHJvX3R5cGUgQXMgU3RyaW5nLCBCeVZhbCByb190YmwgQXMgVmFyaWFudCwgQnlSZWYgcm9fcG9zIEFzIExvbmcpIEFzIExvbmcKICAgIERpbSBpIEFzIExvbmcKICAgIEdldFJvSXggPSAtMQogICAgcm9fcG9zID0gMAogICAgRm9yIGkgPSAwIFRvIFVCb3VuZChyb190YmwpCiAgICAgICAgSWYgcm9fdHlwZSA9IHJvX3RibChpKSBUaGVuCiAgICAgICAgICAgIEdldFJvSXggPSBpCiAgICAgICAgICAgIEV4aXQgRnVuY3Rpb24KICAgICAgICBFbmQgSWYKICAgICAgICByb19wb3MgPSByb19wb3MgKyBMZW4ocm9fdGJsKGkpKQogICAgTmV4dApFbmQgRnVuY3Rpb24KJ+WAi+S6uuOBrumAmuOBl+ODhuODvOODluODq+S9nOaIkApQcml2YXRlIEZ1bmN0aW9uIGNyZWF0ZV9wZXJzb25fdGFibGUoQnlWYWwgcm90YmwgQXMgVmFyaWFudCkgQXMgVmFyaWFudAogICAgRGltIGkgQXMgTG9uZwogICAgRGltIGogQXMgTG9uZwogICAgRGltIGsgQXMgTG9uZwogICAgRGltIG90YmwgQXMgVmFyaWFudAogICAgRGltIHN0ciBBcyBTdHJpbmcKICAgIG90YmwgPSBBcnJheSgiIikKICAgIGsgPSAwCiAgICBGb3IgaSA9IDAgVG8gVUJvdW5kKHJvdGJsKQogICAgICAgIHN0ciA9IHJvdGJsKGkpCiAgICAgICAgRm9yIGogPSAxIFRvIExlbihzdHIpCiAgICAgICAgICAgIFJlRGltIFByZXNlcnZlIG90YmwoaykKICAgICAgICAgICAgb3RibChrKSA9IE1pZChzdHIsIGosIDEpCiAgICAgICAgICAgIGsgPSBrICsgMQogICAgICAgIE5leHQKICAgIE5leHQKICAgIGNyZWF0ZV9wZXJzb25fdGFibGUgPSBvdGJsCkVuZCBGdW5jdGlvbgo=