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~12月の当番表作成
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=