Option Explicit
 
Public Sub 関数設定()
    Dim ws As Worksheet
    Dim dd As Long
    Dim gp As Long
    Dim lastday As Long
    Dim yyyy As Long
    Dim mm As Long
    Dim wrow As Long
    Dim wcol As Long
    Dim wstr As String
    Set ws = ActiveSheet
    If GetVal(ws.Cells(2, "B").Value, 2000, 2099, yyyy) = False Then
        MsgBox ("年が不正です。")
        Exit Sub
    End If
    If GetVal(ws.Cells(3, "B").Value, 1, 12, mm) = False Then
        MsgBox ("月が不正です。")
        Exit Sub
    End If
    lastday = GetLastDay(yyyy, mm)
    For dd = 1 To lastday
        wrow = 3 + (dd - 1) * 3
        For gp = 1 To 4
            wcol = 10 + (gp - 1) * 5
            Call set_func(ws, wrow, wcol, wcol + 1, 1)
            Call set_func(ws, wrow, wcol, wcol + 2, 2)
            Call set_func(ws, wrow, wcol, wcol + 3, 2)
            Call set_func(ws, wrow, wcol, wcol + 4, 3)
        Next
    Next
    MsgBox ("完了")
End Sub
'関数設定
Private Sub set_func(ByVal ws As Worksheet, ByVal trg_row As Long, ByVal ref_col As Long, ByVal trg_col As Long, ByVal count As Long)
    Dim rfcol As String
    Dim fmt As String
    Dim res As String
    Dim row1 As String
    Dim row2 As String
    Dim row3 As String
 
    Const base As String = "=IFS(OR($JROW1=""午前①"",$JROW1=""午前②""),IF($HROW1>=COUNT,""出勤"","""")," & _
                            "OR($JROW1=""午後①"",$JROW1=""午後②""),IF($HROW2>=COUNT,""出勤"","""")," & _
                            "OR($JROW1=""夜間①"",$JROW1=""夜間②""),IF($HROW3>=COUNT,""出勤"","""")," & _
                            "OR($JROW1=""待機①"",$JROW1=""待機②""),"""")"
    If IsError(ws.Cells(trg_row, trg_col).Value) = False Then
        If ws.Cells(trg_row, trg_col).Value <> "" Then
            If ws.Cells(trg_row, trg_col).HasFormula = False Then Exit Sub
        End If
    End If
    rfcol = ConvertToLetter(ref_col)
    row1 = trg_row
    row2 = trg_row + 1
    row3 = trg_row + 2
    fmt = base
    fmt = Replace(fmt, "J", rfcol)
    fmt = Replace(fmt, "ROW1", trg_row)
    fmt = Replace(fmt, "ROW2", trg_row + 1)
    fmt = Replace(fmt, "ROW3", trg_row + 2)
    fmt = Replace(fmt, "COUNT", count)
    ws.Cells(trg_row, trg_col).Formula = fmt
End Sub
'年／月取得
Private Function GetVal(ByVal str As String, ByVal low_limit As Long, ByVal high_limit As Long, ByRef val As Long) As Boolean
    GetVal = False
    If IsNumeric(str) = False Then Exit Function
    val = CLng(str)
    If val < low_limit Then Exit Function
    If val > high_limit Then Exit Function
    GetVal = True
End Function
 
 
'列番号をA～Zの文字に変換
Function ConvertToLetter(iCol As Long) As String
    Dim a As Long
    Dim b As Long
    a = iCol
    ConvertToLetter = ""
    Do While iCol > 0
        a = Int((iCol - 1) / 26)
        b = (iCol - 1) Mod 26
        ConvertToLetter = Chr(b + 65) & ConvertToLetter
        iCol = a
    Loop
End Function
 
'月末日取得
Private Function GetLastDay(ByVal yyyy As Long, ByVal mm As Long) As Long
    Dim wday As Date
    mm = mm + 1
    If mm > 12 Then
        yyyy = yyyy + 1
        mm = 1
    End If
    wday = DateSerial(yyyy, mm, 1)
    wday = wday - 1
    GetLastDay = Day(wday)
End Function
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOmWouaVsOioreWumigpCiAgICBEaW0gd3MgQXMgV29ya3NoZWV0CiAgICBEaW0gZGQgQXMgTG9uZwogICAgRGltIGdwIEFzIExvbmcKICAgIERpbSBsYXN0ZGF5IEFzIExvbmcKICAgIERpbSB5eXl5IEFzIExvbmcKICAgIERpbSBtbSBBcyBMb25nCiAgICBEaW0gd3JvdyBBcyBMb25nCiAgICBEaW0gd2NvbCBBcyBMb25nCiAgICBEaW0gd3N0ciBBcyBTdHJpbmcKICAgIFNldCB3cyA9IEFjdGl2ZVNoZWV0CiAgICBJZiBHZXRWYWwod3MuQ2VsbHMoMiwgIkIiKS5WYWx1ZSwgMjAwMCwgMjA5OSwgeXl5eSkgPSBGYWxzZSBUaGVuCiAgICAgICAgTXNnQm94ICgi5bm044GM5LiN5q2j44Gn44GZ44CCIikKICAgICAgICBFeGl0IFN1YgogICAgRW5kIElmCiAgICBJZiBHZXRWYWwod3MuQ2VsbHMoMywgIkIiKS5WYWx1ZSwgMSwgMTIsIG1tKSA9IEZhbHNlIFRoZW4KICAgICAgICBNc2dCb3ggKCLmnIjjgYzkuI3mraPjgafjgZnjgIIiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgIGxhc3RkYXkgPSBHZXRMYXN0RGF5KHl5eXksIG1tKQogICAgRm9yIGRkID0gMSBUbyBsYXN0ZGF5CiAgICAgICAgd3JvdyA9IDMgKyAoZGQgLSAxKSAqIDMKICAgICAgICBGb3IgZ3AgPSAxIFRvIDQKICAgICAgICAgICAgd2NvbCA9IDEwICsgKGdwIC0gMSkgKiA1CiAgICAgICAgICAgIENhbGwgc2V0X2Z1bmMod3MsIHdyb3csIHdjb2wsIHdjb2wgKyAxLCAxKQogICAgICAgICAgICBDYWxsIHNldF9mdW5jKHdzLCB3cm93LCB3Y29sLCB3Y29sICsgMiwgMikKICAgICAgICAgICAgQ2FsbCBzZXRfZnVuYyh3cywgd3Jvdywgd2NvbCwgd2NvbCArIDMsIDIpCiAgICAgICAgICAgIENhbGwgc2V0X2Z1bmMod3MsIHdyb3csIHdjb2wsIHdjb2wgKyA0LCAzKQogICAgICAgIE5leHQKICAgIE5leHQKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIKJ+mWouaVsOioreWumgpQcml2YXRlIFN1YiBzZXRfZnVuYyhCeVZhbCB3cyBBcyBXb3Jrc2hlZXQsIEJ5VmFsIHRyZ19yb3cgQXMgTG9uZywgQnlWYWwgcmVmX2NvbCBBcyBMb25nLCBCeVZhbCB0cmdfY29sIEFzIExvbmcsIEJ5VmFsIGNvdW50IEFzIExvbmcpCiAgICBEaW0gcmZjb2wgQXMgU3RyaW5nCiAgICBEaW0gZm10IEFzIFN0cmluZwogICAgRGltIHJlcyBBcyBTdHJpbmcKICAgIERpbSByb3cxIEFzIFN0cmluZwogICAgRGltIHJvdzIgQXMgU3RyaW5nCiAgICBEaW0gcm93MyBBcyBTdHJpbmcKICAgIAogICAgQ29uc3QgYmFzZSBBcyBTdHJpbmcgPSAiPUlGUyhPUigkSlJPVzE9IiLljYjliY3ikaAiIiwkSlJPVzE9IiLljYjliY3ikaEiIiksSUYoJEhST1cxPj1DT1VOVCwiIuWHuuWLpCIiLCIiIiIpLCIgJiBfCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAiT1IoJEpST1cxPSIi5Y2I5b6M4pGgIiIsJEpST1cxPSIi5Y2I5b6M4pGhIiIpLElGKCRIUk9XMj49Q09VTlQsIiLlh7rli6QiIiwiIiIiKSwiICYgXwogICAgICAgICAgICAgICAgICAgICAgICAgICAgIk9SKCRKUk9XMT0iIuWknOmWk+KRoCIiLCRKUk9XMT0iIuWknOmWk+KRoSIiKSxJRigkSFJPVzM+PUNPVU5ULCIi5Ye65YukIiIsIiIiIiksIiAmIF8KICAgICAgICAgICAgICAgICAgICAgICAgICAgICJPUigkSlJPVzE9IiLlvoXmqZ/ikaAiIiwkSlJPVzE9IiLlvoXmqZ/ikaEiIiksIiIiIikiCiAgICBJZiBJc0Vycm9yKHdzLkNlbGxzKHRyZ19yb3csIHRyZ19jb2wpLlZhbHVlKSA9IEZhbHNlIFRoZW4KICAgICAgICBJZiB3cy5DZWxscyh0cmdfcm93LCB0cmdfY29sKS5WYWx1ZSA8PiAiIiBUaGVuCiAgICAgICAgICAgIElmIHdzLkNlbGxzKHRyZ19yb3csIHRyZ19jb2wpLkhhc0Zvcm11bGEgPSBGYWxzZSBUaGVuIEV4aXQgU3ViCiAgICAgICAgRW5kIElmCiAgICBFbmQgSWYKICAgIHJmY29sID0gQ29udmVydFRvTGV0dGVyKHJlZl9jb2wpCiAgICByb3cxID0gdHJnX3JvdwogICAgcm93MiA9IHRyZ19yb3cgKyAxCiAgICByb3czID0gdHJnX3JvdyArIDIKICAgIGZtdCA9IGJhc2UKICAgIGZtdCA9IFJlcGxhY2UoZm10LCAiSiIsIHJmY29sKQogICAgZm10ID0gUmVwbGFjZShmbXQsICJST1cxIiwgdHJnX3JvdykKICAgIGZtdCA9IFJlcGxhY2UoZm10LCAiUk9XMiIsIHRyZ19yb3cgKyAxKQogICAgZm10ID0gUmVwbGFjZShmbXQsICJST1czIiwgdHJnX3JvdyArIDIpCiAgICBmbXQgPSBSZXBsYWNlKGZtdCwgIkNPVU5UIiwgY291bnQpCiAgICB3cy5DZWxscyh0cmdfcm93LCB0cmdfY29sKS5Gb3JtdWxhID0gZm10CkVuZCBTdWIKJ+W5tO+8j+aciOWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIEdldFZhbChCeVZhbCBzdHIgQXMgU3RyaW5nLCBCeVZhbCBsb3dfbGltaXQgQXMgTG9uZywgQnlWYWwgaGlnaF9saW1pdCBBcyBMb25nLCBCeVJlZiB2YWwgQXMgTG9uZykgQXMgQm9vbGVhbgogICAgR2V0VmFsID0gRmFsc2UKICAgIElmIElzTnVtZXJpYyhzdHIpID0gRmFsc2UgVGhlbiBFeGl0IEZ1bmN0aW9uCiAgICB2YWwgPSBDTG5nKHN0cikKICAgIElmIHZhbCA8IGxvd19saW1pdCBUaGVuIEV4aXQgRnVuY3Rpb24KICAgIElmIHZhbCA+IGhpZ2hfbGltaXQgVGhlbiBFeGl0IEZ1bmN0aW9uCiAgICBHZXRWYWwgPSBUcnVlCkVuZCBGdW5jdGlvbgoKCifliJfnlarlj7fjgpJB772eWuOBruaWh+Wtl+OBq+WkieaPmwpGdW5jdGlvbiBDb252ZXJ0VG9MZXR0ZXIoaUNvbCBBcyBMb25nKSBBcyBTdHJpbmcKICAgIERpbSBhIEFzIExvbmcKICAgIERpbSBiIEFzIExvbmcKICAgIGEgPSBpQ29sCiAgICBDb252ZXJ0VG9MZXR0ZXIgPSAiIgogICAgRG8gV2hpbGUgaUNvbCA+IDAKICAgICAgICBhID0gSW50KChpQ29sIC0gMSkgLyAyNikKICAgICAgICBiID0gKGlDb2wgLSAxKSBNb2QgMjYKICAgICAgICBDb252ZXJ0VG9MZXR0ZXIgPSBDaHIoYiArIDY1KSAmIENvbnZlcnRUb0xldHRlcgogICAgICAgIGlDb2wgPSBhCiAgICBMb29wCkVuZCBGdW5jdGlvbgoKJ+aciOacq+aXpeWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIEdldExhc3REYXkoQnlWYWwgeXl5eSBBcyBMb25nLCBCeVZhbCBtbSBBcyBMb25nKSBBcyBMb25nCiAgICBEaW0gd2RheSBBcyBEYXRlCiAgICBtbSA9IG1tICsgMQogICAgSWYgbW0gPiAxMiBUaGVuCiAgICAgICAgeXl5eSA9IHl5eXkgKyAxCiAgICAgICAgbW0gPSAxCiAgICBFbmQgSWYKICAgIHdkYXkgPSBEYXRlU2VyaWFsKHl5eXksIG1tLCAxKQogICAgd2RheSA9IHdkYXkgLSAxCiAgICBHZXRMYXN0RGF5ID0gRGF5KHdkYXkpCkVuZCBGdW5jdGlvbgo=