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 ws.Cells(trg_row, trg_col).Value <> "" Then Exit Sub
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/ikaEiIiksIiIiIikiCiAgICAKICAgIElmIHdzLkNlbGxzKHRyZ19yb3csIHRyZ19jb2wpLlZhbHVlIDw+ICIiIFRoZW4gRXhpdCBTdWIKICAgIHJmY29sID0gQ29udmVydFRvTGV0dGVyKHJlZl9jb2wpCiAgICByb3cxID0gdHJnX3JvdwogICAgcm93MiA9IHRyZ19yb3cgKyAxCiAgICByb3czID0gdHJnX3JvdyArIDIKICAgIGZtdCA9IGJhc2UKICAgIGZtdCA9IFJlcGxhY2UoZm10LCAiSiIsIHJmY29sKQogICAgZm10ID0gUmVwbGFjZShmbXQsICJST1cxIiwgdHJnX3JvdykKICAgIGZtdCA9IFJlcGxhY2UoZm10LCAiUk9XMiIsIHRyZ19yb3cgKyAxKQogICAgZm10ID0gUmVwbGFjZShmbXQsICJST1czIiwgdHJnX3JvdyArIDIpCiAgICBmbXQgPSBSZXBsYWNlKGZtdCwgIkNPVU5UIiwgY291bnQpCiAgICB3cy5DZWxscyh0cmdfcm93LCB0cmdfY29sKS5Gb3JtdWxhID0gZm10CkVuZCBTdWIKJ+W5tO+8j+aciOWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIEdldFZhbChCeVZhbCBzdHIgQXMgU3RyaW5nLCBCeVZhbCBsb3dfbGltaXQgQXMgTG9uZywgQnlWYWwgaGlnaF9saW1pdCBBcyBMb25nLCBCeVJlZiB2YWwgQXMgTG9uZykgQXMgQm9vbGVhbgogICAgR2V0VmFsID0gRmFsc2UKICAgIElmIElzTnVtZXJpYyhzdHIpID0gRmFsc2UgVGhlbiBFeGl0IEZ1bmN0aW9uCiAgICB2YWwgPSBDTG5nKHN0cikKICAgIElmIHZhbCA8IGxvd19saW1pdCBUaGVuIEV4aXQgRnVuY3Rpb24KICAgIElmIHZhbCA+IGhpZ2hfbGltaXQgVGhlbiBFeGl0IEZ1bmN0aW9uCiAgICBHZXRWYWwgPSBUcnVlCkVuZCBGdW5jdGlvbgoKCifliJfnlarlj7fjgpJB772eWuOBruaWh+Wtl+OBq+WkieaPmwpGdW5jdGlvbiBDb252ZXJ0VG9MZXR0ZXIoaUNvbCBBcyBMb25nKSBBcyBTdHJpbmcKICAgIERpbSBhIEFzIExvbmcKICAgIERpbSBiIEFzIExvbmcKICAgIGEgPSBpQ29sCiAgICBDb252ZXJ0VG9MZXR0ZXIgPSAiIgogICAgRG8gV2hpbGUgaUNvbCA+IDAKICAgICAgICBhID0gSW50KChpQ29sIC0gMSkgLyAyNikKICAgICAgICBiID0gKGlDb2wgLSAxKSBNb2QgMjYKICAgICAgICBDb252ZXJ0VG9MZXR0ZXIgPSBDaHIoYiArIDY1KSAmIENvbnZlcnRUb0xldHRlcgogICAgICAgIGlDb2wgPSBhCiAgICBMb29wCkVuZCBGdW5jdGlvbgoKJ+aciOacq+aXpeWPluW+lwpQcml2YXRlIEZ1bmN0aW9uIEdldExhc3REYXkoQnlWYWwgeXl5eSBBcyBMb25nLCBCeVZhbCBtbSBBcyBMb25nKSBBcyBMb25nCiAgICBEaW0gd2RheSBBcyBEYXRlCiAgICBtbSA9IG1tICsgMQogICAgSWYgbW0gPiAxMiBUaGVuCiAgICAgICAgeXl5eSA9IHl5eXkgKyAxCiAgICAgICAgbW0gPSAxCiAgICBFbmQgSWYKICAgIHdkYXkgPSBEYXRlU2VyaWFsKHl5eXksIG1tLCAxKQogICAgd2RheSA9IHdkYXkgLSAxCiAgICBHZXRMYXN0RGF5ID0gRGF5KHdkYXkpCkVuZCBGdW5jdGlvbgo=