n7822123

回復 20# 軒云熊


準提大大的版本 排版更是清楚

準大的版本看起來很舒服，

你已經要放棄你原本很花的格式，想用準大的版本了嗎XD  　

需求：

如果要設定幾輪上　夜班　日班
但我應該在哪一段修改　要怎麼寫？

準大不是用純VBA做的，有搭配定義名稱、函數公式

簡單來說，不能只給你VBA程式~

先開欄位吧~~如下圖

下載 (40.72 KB)

2020-6-29 23:51

儲存格C8 新增一個選項 "日夜輪流"

假設一樣做4休2，6天為1輪，第1~4輪上日班，第6~10輪上夜班，第11輪又回到日班，以此類推~

你要的功能，只需要修改 "Sub 日曆_排班" 這個程序即可

而且資料的部分更是只需修改AD、AE 兩欄，此程序的後段程式與資料無關，內容大概是

用VBA設公式(抓AD、AE資料)>複製公式>清除公式>設儲存格顏色(依[aRngColor]格式)

也就只是把月曆格式弄出來而已，你有興趣也可以研究一下

準大寫的程式應該可以讓你學到很多~~~前提是你要能看得懂~

根據你的需求，我把我新增的程式用紅色 Hight Light

這樣你可以比較好區分改了哪些，為什麼這樣改~

我的程式是假設 先輪日班 再輪夜班，如果你要顛倒，可以試著改看看~真的不難


Sub 日曆_排班()
Dim D1&, D2&, xDay&, xMon&, xTP$, xVM&, xVD1%, xVD2%
Dim Arr, i&, R&, C&, C2&, N&, TN&, T$, xR As Range
If [A_Head] = [A_End] Then MsgBox "**〔月曆〕尚未建立!   ":  Exit Sub
D1 = [A_Head]: D2 = [A_End] + 30
'---------------------------------
xDay = [aRng1]: If xDay = 0 Then xDay = D1
If xDay < D1 Or xDay > D2 Then MsgBox "〔排班首日〕超出日曆範圍!   ":  Exit Sub
xMon = Format(xDay, "yyyymm")
'---------------------------------
xTP = [aRng2]: If xTP = "" Then MsgBox "〔排班班別〕未輸入!   ": Exit Sub
If xTP = "日夜輪流" Then Turn = True
xVM = [aRng3]: If xVM = 0 Then MsgBox "〔排班月數〕未輸入!   ": Exit Sub
xVD1 = [aRng4]: If xVD1 = 0 Then MsgBox "〔排班天數〕未輸入!   ": Exit Sub
xVD2 = [aRng5]: If xVD2 = 0 Then MsgBox "〔休息天數〕未輸入!   ": Exit Sub
Dturn = [aRng6]: NTurn = [aRng7]
If Turn And (Dturn = "" Or NTurn = "") Then MsgBox "〔日、夜班輪數〕未輸入完全"  : Exit Sub
'---------------------------------
Call 日曆_排班_重置
ReDim Arr(1 To D2 - xDay + 1, 1 To 2)
For i = xDay To D2
    xMon = Format(i, "yyyymm")
    If xMon <> YM Then YM = xMon: N = N + 1
    TN = Int((i - D1 + 1) / (xVD1 + xVD2))
    If N > xVM Then Exit For
    R = R + 1
    C = C Mod (xVD1 + xVD2) + 1
    C2 = TN Mod (Dturn + NTurn) + 1
    T = IIf(Turn, IIf(C2 > Dturn, "夜班", "日班"), xTP)
    If C > xVD1 Then T = "休息"
    Arr(R, 1) = i
    Arr(R, 2) = T
Next i
[AD1] = "＜日期＞": [AE1] = "＜班別＞"
[AD2:AE2].Resize(R) = Arr
...
...
...

練習日期v01-0630.rar (107.3 KB)

下載次數: 9

2020-6-30 00:49

n7822123

回復 21# n7822123


哎! 看錯了，這行改一下

TN = Int((i - xDay + 1) / (xVD1 + xVD2))

軒云熊

謝謝n7822123大大的指點 讓我想到 把 -1 的位置改一下就可以了
DateAdd("d", -1, K) Mod 12 + 1
老實說我真的看不懂  只能F8 慢慢研究XD
準大的版本對我來說好複雜 ...如果有不懂的地方 再請教n7822123大大還有各位前輩們 ^^"

軒云熊

請問 有關於月輪班  跨月的部分問題
當一個月 的最後一輪 到 下個月的第一輪
該用怎麼樣的判斷方式 才可以完整的 把一整輪的天數輪完
而不會因為隔月的問題 導致 錯誤
嘗試了計數的方式 還是不行 會卡到月份問題 有的月份天數不一樣
請前輩們 幫幫忙

下載 (28.31 KB)

2020-7-11 19:58

改版後的班表練習.rar (20.09 KB)

下載次數: 2

2020-7-11 19:59

軒云熊

問題解決了  謝謝準提大大的檔案 還有  n7822123大大的 提點
後來想到的方式  是利用  False 跟 True  的 Boolean 變數  然後再把 輪班的顏色次數先存到 儲存格
再延用 就可以了 XD

1.                 If Y <= Cells(6, 11) Then
   
2.                
   
3.                     Select Case DateDiff("d", DateValue(d & "/1/1"), Cells(K, 1)) Mod Cells(5, 11) + 1
   
4.                     Case 1 To Cells(3, 11)
   
5.                     
   
6.                     If Cells(1, 10) <> Year(Date) Then sss = True
   
7.                     
   
8.                     If yyy <> 0 And yyy <> Cells(3, 11) And sss = True Then
   
9.                     
   
10.                         Cells(U + 1, W) = "夜班"
    
11.                         Cells(U + 1, W).Font.Color = RGB(114, 0, 55)
    
12.                         Cells(U + 1, W).Interior.Color = RGB(255, 208, 0)
    
13.                         
    
14.                         If Cells(U + 1, W) <> "休假" And Cells(U + 1, W) <> "上班" Then yyy = yyy + 1
    
15.                         Cells(1, 13) = yyy '儲存延伸天數
    
16.                         
    
17.                         If yyy = Cells(3, 11) Then
    
18.                            yyy = 0
    
19.                            sss = False
    
20.                         End If
    
21.                         
    
22.                     Else
    
23.                         Cells(U + 1, W) = "上班"
    
24.                         Cells(U + 1, W).Font.Color = RGB(0, 0, 89)
    
25.                         Cells(U + 1, W).Interior.Color = RGB(150, 201, 123)
    
26.                     End If
    
27.                     
    
28.                         If Cells(U + 1, W) <> "休假" And Cells(U + 1, W) <> "夜班" Then kkk = kkk + 1
    
29.                         Cells(1, 12) = kkk '儲存延伸天數
    
30.                         If kkk = Cells(3, 11) Then kkk = 0
    
31.                         
    
32.                     End Select
    
33.                     
    
34.                 ElseIf Y <= Cells(6, 11) * 2 Then
    
35.                
    
36.                     Select Case DateDiff("d", DateValue(d & "/1/1"), Cells(K, 1)) Mod Cells(5, 11) + 1
    
37.                     Case 1 To Cells(3, 11)
    
38.                     
    
39.                     If Cells(1, 10) <> Year(Date) Then sss = True
    
40.                     
    
41.                     If kkk <> 0 And kkk <> Cells(3, 11) And sss = True Then
    
42.                         
    
43.                         Cells(U + 1, W) = "上班"
    
44.                         Cells(U + 1, W).Font.Color = RGB(0, 0, 89)
    
45.                         Cells(U + 1, W).Interior.Color = RGB(150, 201, 123)
    
46.                         
    
47.                         If Cells(U + 1, W) <> "休假" And Cells(U + 1, W) <> "夜班" Then kkk = kkk + 1
    
48.                         Cells(1, 12) = kkk '儲存延伸天數
    
49. 
    
50.                         If kkk = Cells(3, 11) Then
    
51.                            kkk = 0
    
52.                            sss = False
    
53.                         End If
    
54.                         
    
55.                     Else
    
56.                         Cells(U + 1, W) = "夜班"
    
57.                         Cells(U + 1, W).Font.Color = RGB(114, 0, 55)
    
58.                         Cells(U + 1, W).Interior.Color = RGB(255, 208, 0)
    
59.                     End If
    
60.                     
    
61.                         If Cells(U + 1, W) <> "休假" And Cells(U + 1, W) <> "上班" Then yyy = yyy + 1
    
62.                         Cells(1, 13) = yyy '儲存延伸天數
    
63.                         If yyy = Cells(3, 11) Then yyy = 0
    
64.                            
    
65.                     End Select
    
66.                     
    
67.                 End If

複製代碼

謝謝大大們的指導