fork download
copy 
  1. Option Explicit
  2. Const Shift_str As String = "1,1,1,1,定休,2,2,2,2,定休,3,3,3,3,定休,定休"
  3. Const A_stx As Long = 6         'Aグループの2020年1月1日のインデックス
  4. Const B_stx As Long = 2         'Bグループの2020年1月1日のインデックス
  5. Const C_stx As Long = 14        'Cグループの2020年1月1日のインデックス
  6. Const D_stx As Long = 10        'Dグループの2020年1月1日のインデックス
  7. Dim ws As Worksheet
  8. Dim cs As Worksheet
  9. Dim shift_p As Variant
  10. Dim dicT As Object          '祝日カレンダーの祝日を記憶
  11. Public Sub 週間シフト表作成()
  12.     Dim sdate As Variant
  13.     Dim wdate As Variant
  14.     Dim flag As Boolean
  15.     Dim i As Long
  16.     Dim wx As Long
  17.     Dim maxrow As Long
  18.     Dim wrow As Long
  19.     Dim wcol As Long
  20.     Dim diff As Long
  21.     Dim aix As Long
  22.     Dim bix As Long
  23.     Dim cix As Long
  24.     Dim dix As Long
  25.     Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
  26.     shift_p = Split(Shift_str, ",")
  27.     Set ws = Worksheets("週間シフト表")
  28.     Set cs = Worksheets("祝日")
  29.     sdate = ws.Cells(4, "B").Value
  30.     flag = False
  31.     If IsDate(sdate) = True Then
  32.         If Year(sdate) >= 2020 And Year(sdate) <= 2099 Then
  33.             flag = True
  34.         End If
  35.     End If
  36.     If flag = False Then
  37.         MsgBox ("2020年～2099年の日付を指定してください")
  38.         Exit Sub
  39.     End If
  40.     ws.Cells(3, "B").Value = Year(sdate) & "年"
  41.     ws.Cells(3, "C").Value = Month(sdate) & "月"
  42.     maxrow = cs.Cells(Rows.Count, 1).End(xlUp).row    '最終行を求める
  43.     '祝日カレンダーを記憶
  44.     For wrow = 2 To maxrow
  45.         dicT(cs.Cells(wrow, "A").Value) = True
  46.     Next
  47.     '日付設定
  48.     For i = 0 To 6
  49.         wdate = sdate + i
  50.         wrow = 4
  51.         wcol = 2 + i
  52.         ws.Cells(wrow, wcol).Value = wdate
  53.         wx = Weekday(wdate, vbSunday)
  54.         '祝日か日曜日なら赤
  55.         ws.Cells(wrow, wcol).Font.ColorIndex = xlAutomatic
  56.         If dicT.exists(wdate) = True Or wx = 1 Then
  57.             ws.Cells(wrow, wcol).Font.Color = -16776961
  58.             '土曜日なら青
  59.         ElseIf wx = 7 Then
  60.             ws.Cells(wrow, wcol).Font.Color = -1003520
  61.         End If
  62.     Next
  63.     'シフト設定
  64.     diff = sdate - DateSerial(2020, 1, 1)
  65.     aix = (diff + A_stx) Mod 16
  66.     bix = (diff + B_stx) Mod 16
  67.     cix = (diff + C_stx) Mod 16
  68.     dix = (diff + D_stx) Mod 16
  69.     For i = 0 To 6
  70.         wrow = 6
  71.         wcol = 2 + i
  72.         ws.Range(ws.Cells(wrow, wcol), ws.Cells(wrow + 4, wcol)).Value = shift_p(aix)    'Aのシフト
  73.         wrow = wrow + 5
  74.         ws.Range(ws.Cells(wrow, wcol), ws.Cells(wrow + 4, wcol)).Value = shift_p(bix)    'Bのシフト
  75.         wrow = wrow + 5
  76.         ws.Range(ws.Cells(wrow, wcol), ws.Cells(wrow + 4, wcol)).Value = shift_p(cix)    'Cのシフト
  77.         wrow = wrow + 5
  78.         ws.Range(ws.Cells(wrow, wcol), ws.Cells(wrow + 4, wcol)).Value = shift_p(dix)    'Dのシフト
  79.         aix = next_shift(aix)
  80.         bix = next_shift(bix)
  81.         cix = next_shift(cix)
  82.         dix = next_shift(dix)
  83.     Next
  84. End Sub
  85. '次のシフトを取得
  86. Private Function next_shift(ByVal shift_ix As Long) As Long
  87.     next_shift = shift_ix + 1
  88.     If next_shift > 15 Or next_shift < 0 Then
  89.         next_shift = 0
  90.     End If
  91. End Function
  92.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/ZTDV83
language:
Text (text 6.10)
created:
5 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!