Board logo

標題: [發問] 請問 ARRAY範圍 改成 動態 指定 範圍問題 請前輩們指教 [打印本頁]
作者: 軒云熊    時間: 2020-6-15 13:42     標題: 請問 ARRAY範圍 改成 動態 指定 範圍問題 請前輩們指教

Private Sub CommandButton2_Click()
'3個月
If TextBox2.Value = 1 Then A = Array(3, 5, 7, 15, 17, 19)
If TextBox2.Value = 2 Then A = Array(5, 7, 9, 17, 19, 21)
If TextBox2.Value = 3 Then A = Array(7, 9, 11, 19, 21, 23)
If TextBox2.Value = 4 Then A = Array(9, 11, 13, 21, 23, 25)
If TextBox2.Value = 5 Then A = Array(11, 13, 15, 23, 25)
If TextBox2.Value = 6 Then A = Array(13, 15, 17, 25)
If TextBox2.Value = 7 Then A = Array(15, 17, 19)
If TextBox2.Value = 8 Then A = Array(17, 19, 21)
If TextBox2.Value = 9 Then A = Array(19, 21, 23)
If TextBox2.Value = 10 Then A = Array(21, 23, 25)
If TextBox2.Value = 11 Then A = Array(23, 25)
If TextBox2.Value = 12 Then A = Array(25)
If TextBox2.Value = "" Then A = Array(3, 5, 7, 15, 17, 19)

For I = LBound(A) To UBound(A)
    For J = 4 To Cells(3, 4).End(xlToRight).Column
        If Cells(A(I), J) = "日班" Then Cells(A(I), J) = "夜班"
        If Cells(A(I), J) <> "" And Cells(A(I), J) = "夜班" Then
           Cells(A(I), J).Font.Color = RGB(Cells(1, 26), Cells(1, 27), Cells(1, 28))
           Cells(A(I), J).Interior.Color = RGB(Cells(1, 32), Cells(1, 33), Cells(1, 34))
        End If
    Next J
Next I
Erase A

UserForm3.Hide
TextBox2.Value = ""
End Sub

請問前輩們 以下這段該如何改寫 才能夠改成動態的規律 如何可以縮減程式碼
還有一個延伸問題 當延伸到最後一個月時不滿3個月 該如何延伸至下一年的第一個月
請前輩們指教 程式特別攏長 看起來可能會有些不方便 不好意思 ^^"

If TextBox2.Value = 1 Then A = Array(3, 5, 7, 15, 17, 19)
If TextBox2.Value = 2 Then A = Array(5, 7, 9, 17, 19, 21)
If TextBox2.Value = 3 Then A = Array(7, 9, 11, 19, 21, 23)
If TextBox2.Value = 4 Then A = Array(9, 11, 13, 21, 23, 25)
If TextBox2.Value = 5 Then A = Array(11, 13, 15, 23, 25)
If TextBox2.Value = 6 Then A = Array(13, 15, 17, 25)
If TextBox2.Value = 7 Then A = Array(15, 17, 19)
If TextBox2.Value = 8 Then A = Array(17, 19, 21)
If TextBox2.Value = 9 Then A = Array(19, 21, 23)
If TextBox2.Value = 10 Then A = Array(21, 23, 25)
If TextBox2.Value = 11 Then A = Array(23, 25)
If TextBox2.Value = 12 Then A = Array(25)
If TextBox2.Value = "" Then A = Array(3, 5, 7, 15, 17, 19)
[attach]32173[/attach]
作者: 軒云熊    時間: 2020-6-15 14:05

就是月份的部分  改成可以用輸入表單的方式 2個月輪一次 或著是 3個月輪一次
作者: 准提部林    時間: 2020-6-16 11:52

回復 2# 軒云熊

自己寫的規則自己看得懂, 這才是最重要的, 簡化不一定就好!!!
只一張工作表就看得眼花, 不太想去了解,
日期做成文字, 對EXCEL來說, 不是好習慣, 對往後的維護及統計運算都有障礙,
讓看到的是"格式", 內容是真實數值, 是最好的~~
作者: 軒云熊    時間: 2020-6-16 13:28

謝謝准提大大 往後我會改掉這個壞習慣的
作者: n7822123    時間: 2020-6-17 01:56

本帖最後由 n7822123 於 2020-6-17 02:06 編輯

回復 1# 軒云熊

需求：
請問前輩們 以下這段該如何改寫 才能夠改成動態的規律 如何可以縮減程式碼

If TextBox2.Value = 1 Then A = Array(3, 5, 7, 15, 17, 19)
If TextBox2.Value = 2 Then A = Array(5, 7, 9, 17, 19, 21)
If TextBox2.Value = 3 Then A = Array(7, 9, 11, 19, 21, 23)
If TextBox2.Value = 4 Then A = Array(9, 11, 13, 21, 23, 25)
If TextBox2.Value = 5 Then A = Array(11, 13, 15, 23, 25)
If TextBox2.Value = 6 Then A = Array(13, 15, 17, 25)
If TextBox2.Value = 7 Then A = Array(15, 17, 19)
If TextBox2.Value = 8 Then A = Array(17, 19, 21)
If TextBox2.Value = 9 Then A = Array(19, 21, 23)
If TextBox2.Value = 10 Then A = Array(21, 23, 25)
If TextBox2.Value = 11 Then A = Array(23, 25)
If TextBox2.Value = 12 Then A = Array(25)
If TextBox2.Value = "" Then A = Array(3, 5, 7, 15, 17, 19)

同意準大說的，自己寫的程式自己能看懂，才是最好的！
別人寫的很短很厲害，你如果看不懂，之後要改程式也無從下手，會更痛苦
依你的需求，程式改成如下，但執行速度不會比較快~

k = TextBox2.Value: If k = "" Then k = 1
For i = k To 12: Idx = Idx + 1
  If Idx < 4 Or Idx > 6 Then
    itm = itm + 1: If itm = 7 Then Exit For
    s = s & "," & i * 2 + 1
  End If
Next i
A = Split(Mid(s, 2), ",")
作者: n7822123    時間: 2020-6-17 02:16

本帖最後由 n7822123 於 2020-6-17 02:30 編輯

回復 1# 軒云熊


寫法二：
k = TextBox2.Value: If k = "" Then k = 1
For i = k To 12
  s = s & "," & i * 2 + 1
  itm = itm + 1: If itm = 6 Then Exit For
  If i = k + 2 Then i = i + 5
Next i
A = Split(Mid(s, 2), ",")

看你覺得那個你比較好理解
新手不建議在For迴圈裡面改For迴圈的變數值
以免不小心就弄成無窮迴圈，所以不太推薦此寫法
作者: n7822123    時間: 2020-6-17 02:33

本帖最後由 n7822123 於 2020-6-17 02:43 編輯

回復 6# n7822123


漏改到，修正寫法二

k = TextBox2.Value: If k = "" Then k = 1
For i = k To 12
  s = s & "," & i * 2 + 1
  itm = itm + 1: If itm = 6 Then Exit For
  If i = k + 2 Then i = i + 3    '跳過後3個迴圈
Next i
A = Split(Mid(s, 2), ",")
作者: 軒云熊    時間: 2020-6-17 12:38

謝謝 n7822123 大大  程式少很多行了
當延伸到最後一個月時不滿3個月 該如何延伸至下一年的第一個月呢?
作者: 准提部林    時間: 2020-6-17 19:03

本帖最後由 准提部林 於 2020-6-17 19:05 編輯

回復 8# 軒云熊


1) 日曆只有一年份, 怎延伸下年度???
2) 為何要弄這麼多form???
3) 填底色而己, 何以要用vga表單去調, 不覺太複雜???
4) 每個月用31欄, 要怎列印成一張?
作者: 軒云熊    時間: 2020-6-17 19:11

回准提大大那個我只是想要練習用的因為我還是新手>"<    R1C4 的 2020 改成2021 可以延伸顯示下一年份
班別 輪班 的部分 是可以延伸 但是每個月天數不同 要做到 2~3個月的延伸就卡住了 ^^"
作者: n7822123    時間: 2020-6-23 14:09

本帖最後由 n7822123 於 2020-6-23 14:13 編輯

回復 10# 軒云熊

聽準大的~~你就讓日期回歸到日期格式，別用文字格式玩

日期格式是可以做計算的，用日期格式計算，算到西元3000年~都沒問題

要發問就要把你的問題 提取出來，做成簡單的Excel檔案，可以做測試就好

大部分人(包含我)看到一大串程式，就懶的去研究了，何況大部分程式跟你提問的不相干

所以我本來是懶得回你的~

我做一個小範例讓你參考吧，你的程式不相干的東西有點多，懶的研究

Sub 玩日期()
Dim Date1 As Date, Date2 As Date
CheckOK = False
Do Until CheckOK
  On Error Resume Next
  Date1 = InputBox("請輸入第一天上班日期，" & vbCrLf & " 需要日期格式 Ex：2020/1/1")
  If Err <> 0 Then MsgBox "你輸入的不是日期格式，請修改" Else CheckOK = True
  On Error GoTo 0
Loop
CheckOK = False
Do Until CheckOK
  On Error Resume Next
  Date2 = InputBox("請輸入要查詢的日期，" & vbCrLf & " 需要日期格式 Ex：2020/7/1")
  If Err <> 0 Then MsgBox "你輸入的不是日期格式，請修改" Else CheckOK = True
  On Error GoTo 0
Loop
Date1 = Date1 - 1
If Date2 - Date1 < 0 Then MsgBox "你輸入的查詢日期比第一天上班日還前面": Exit Sub
'以做4休2為例(6天一循環)
Select Case (Date2 - Date1) Mod 6
    Case 1, 2, 3, 4: MsgBox "這天要上班"
    Case 5, 6: MsgBox "恭喜!這天是休假^.^"
End Select
End Sub
作者: 軒云熊    時間: 2020-6-23 17:37

謝謝 n7822123 大大的指教  我會好好研究學習 謝謝您
原本會這樣寫是因為 較直覺 好理解 但會造成計算和格式問題
我會聽準大大的 改掉這個壞習慣的   
的確日期轉文字會造成很多不必要的問題  也會因為轉文字 多寫了很多行 小弟受教了
作者: n7822123    時間: 2020-6-24 00:13

回復 12# 軒云熊

聽你的回覆，感覺你可以自己完成嘍~

另外我的範例程式有點小錯

Sub 玩日期()
Dim Date1 As Date, Date2 As Date
CheckOK = False
Do Until CheckOK
  On Error Resume Next
  Date1 = InputBox("請輸入第一天上班日期，" & vbCrLf & " 需要日期格式 Ex：2020/1/1")
  If Err <> 0 Then MsgBox "你輸入的不是日期格式，請修改" Else CheckOK = True
  On Error GoTo 0
Loop
CheckOK = False
Do Until CheckOK
  On Error Resume Next
  Date2 = InputBox("請輸入要查詢的日期，" & vbCrLf & " 需要日期格式 Ex：2020/7/1")
  If Err <> 0 Then MsgBox "你輸入的不是日期格式，請修改" Else CheckOK = True
  On Error GoTo 0
Loop
Date1 = Date1 - 1
If Date2 - Date1 < 0 Then MsgBox "你輸入的查詢日期比第一天上班日還前面": Exit Sub
'以做4休2為例(6天一循環)
Select Case Int(Date2 - Date1) Mod 6
    Case 1, 2, 3, 4: MsgBox "這天要上班"
    Case 5, 0: MsgBox "恭喜!這天是休假^.^"
End Select
End Sub  
作者: 軒云熊    時間: 2020-6-24 06:05

本帖最後由 軒云熊 於 2020-6-24 06:08 編輯

n7822123大大 我還是沒辦法 不知道為甚麼  上接不到下 有時候會跑失敗 如果加延遲 又變得很慢
不過延伸下一年問題 解決了 已經不需要先存到儲存格 這方法是可以自動延伸  謝謝n7822123大大
Sub 日期練習()
'Application.ScreenUpdating = False

Range(Cells(2, 1).End(xlToRight), Cells(2, 1).End(xlDown)).Clear

    S = 3
    E = 1
    For F = 1 To 12 '建立範圍
        For P = 1 To Day(DateSerial(Year(Now), F + 1, 0))
            Cells(S, E) = DateSerial(Year(Now), F, P)
            Cells(S - 1, E) = F & "月" & P & "日" & WeekdayName(Weekday(P))
            E = E + 1
            If P = Day(DateSerial(Year(Now), F + 1, 0)) Then
            If F = 12 Then Exit For
               S = S + 2
               E = 1
            End If
        Next P
    Next F
   
    For E = ActiveWorkbook.Names.Count To 1 Step -1 '清除定義名稱
       If ActiveWorkbook.Names(E).Name <> "指定範圍" Then
          ActiveWorkbook.Names(E).Delete
       End If
    Next E
   
    Y = 65
    For i = 3 To Cells(3, 1).End(xlDown).Row Step 2 '定義名稱
        範圍名稱 = Chr(Y)
        Names.Add Name:="第" & 範圍名稱 & "項", RefersTo:=Range(Cells(i, 1), Cells(i, 1).End(xlToRight))
        Y = Y + 1
    Next i
    'Application.Wait Now + TimeValue("00:00:01")
   
    Set AWN = ActiveWorkbook.Names '合併
    For R = 1 To AWN.Count
       If R <> 1 Then
          K = Mid(AWN(R).RefersToR1C1Local, 2, Len(AWN(R))) & ","
       Else
          K = AWN(R).RefersToR1C1Local & ","
       End If
        u = u + K
    Next R
   
    Names.Add Name:="指定範圍", RefersTo:=Mid(u, 1, Len(u) - 1)
   
    For E = ActiveWorkbook.Names.Count To 1 Step -1 '清除定義名稱
       If ActiveWorkbook.Names(E).Name <> "指定範圍" Then
          ActiveWorkbook.Names(E).Delete
       End If
    Next E

    For Each G In Range("指定範圍")
        D = G.Offset
        Select Case DateAdd("d", -1, D) Mod 6 + 1
        Case 1 To 4
            G.Offset = "上班"
            G.Offset.Font.Color = RGB(0, 0, 89)
            G.Interior.Color = RGB(150, 201, 123)
        Case 5 To 6
            G.Offset = "休假"
            G.Offset.Font.Color = RGB(114, 0, 55)
            G.Offset.Interior.Color = RGB(255, 255, 92)
        End Select
    Next G
   
'Application.ScreenUpdating = True
End Sub
作者: 軒云熊    時間: 2020-6-24 06:52

如果把  G.Offset = "上班" 和 G.Offset = "休假" 關掉 就不會出錯了 但是 這樣就達不到目的了
不知道有沒有別的方式  
Select Case DateAdd("d", -1, D) Mod 6 + 1 這段有問題  程式已經跑完了 但是還是會停在這裡
說型態不符 但我程式已經跑完了 不知道為甚麼...
    For Each G In Range("指定範圍")
        D = G.Offset
        Select Case DateAdd("d", -1, D) Mod 6 + 1
        Case 1 To 4
'            G.Offset = "上班"
            G.Offset.Font.Color = RGB(0, 0, 89)
            G.Interior.Color = RGB(150, 201, 123)
        Case 5 To 6
'            G.Offset = "休假"
            G.Offset.Font.Color = RGB(114, 0, 55)
            G.Offset.Interior.Color = RGB(255, 255, 92)
        End Select
    Next G
作者: 軒云熊    時間: 2020-6-24 07:20

剛才在最後 多加一個迴圈 把文字跟顏色分開 就可以了 又是格式問題
感謝    準大大 和  n7822123 大大的指導
    For Each H In Range("指定範圍")
        If H.Interior.Color = RGB(150, 201, 123) Then H.Offset = "上班"
        If H.Offset.Interior.Color = RGB(255, 255, 92) Then H.Offset = "休假"
    Next H
作者: 軒云熊    時間: 2020-6-24 15:21

子細看了 n7822123 大大的 Sub 玩日期 ()   發現
把外面再包一個 Int     D = Int(G.Offset)    就正常了不用多加迴圈  >"<
作者: 准提部林    時間: 2020-6-28 11:24

公式+VBA:
[attach]32235[/attach]

那"排班"--僅以 [上?休?] 來排, 不具實用性, 參考吧!
[attach]32236[/attach]
作者: 軒云熊    時間: 2020-6-28 19:36

請問准提大大　如果要設定幾輪上　夜班　日班　假設一輪是１２天
該如何寫呢？
準提大大的版本　排版更是清楚　但我應該在哪一段修改　要怎麼寫？　

以下是之前修改過的　但對我來說已經是極限了．．實在想不出來　＞＂＜
問題出在這裡：
如果用　＂ｗｗ＂　週數計算上班的天數就會有問題．．不知如何修改　
＂ｄ＂天數會搭不到　　
        Select Case DateAdd("d", -1, K) Mod Cells(1, 3) + 1   '常日班
        Case 1 To Cells(1, 4)
            G.Offset = "上班"
            G.Offset.Font.Color = RGB(0, 0, 89)
            G.Interior.Color = RGB(150, 201, 123)
        Case Cells(1, 4) + 1 To Cells(1, 4) + Cells(1, 5)
            If G.Offset >= Cells(1, 1) Then
            G.Offset = "休假"
            G.Offset.Font.Color = RGB(114, 0, 55)
            G.Offset.Interior.Color = RGB(255, 255, 92)
            End If
        End Select
        
        Select Case DateAdd("d", -1, K) Mod Cells(1, 7) + 1 '周輪班
        Case 1 To Cells(1, 4)
            G.Offset = "夜班"
            G.Offset.Font.Color = RGB(114, 0, 55)
            G.Offset.Interior.Color = RGB(255, 208, 0)
        Case Cells(1, 4) + 1 To Cells(1, 4) + Cells(1, 5)
        End Select
　－－－－－－－－－－－－－－－－－－－－－－
  1. Public Sub 周輪班練習()
  2. Range(Cells(2, 1).End(xlToRight), Cells(2, 1).End(xlDown)).Clear
  3. Cells(1, 3) = Cells(1, 4) + Cells(1, 5)
  4. Cells(1, 7) = Cells(1, 3) * 2
  5.    If Cells(1, 2) = "" Then
  6.       Cells(1, 2) = Year(Date)
  7.    Else
  8.       Cells(1, 2) = Cells(1, 2)
  9.    End If

  11.     S = 3
  12.     E = 1
  13.     For F = 1 To 12 '建立範圍
  14.         For P = 1 To Day(DateSerial(Cells(1, 2), F + 1, 0))
  15.             Cells(S, E) = DateSerial(Cells(1, 2), F, P)
  16.             Cells(S - 1, E) = F & "月" & P & "日" & WeekdayName(Weekday(P))
  17.             E = E + 1
  18.             If P = Day(DateSerial(Cells(1, 2), F + 1, 0)) Then
  19.             If F = 12 Then Exit For
  20.                S = S + 2
  21.                E = 1
  22.             End If
  23.         Next P
  24.     Next F
  25.    
  26.     For E = ActiveWorkbook.Names.Count To 1 Step -1 '清除定義名稱
  27.        If ActiveWorkbook.Names(E).Name <> "" Then
  28.           ActiveWorkbook.Names(E).Delete
  29.        End If
  30.     Next E
  31.    
  32.     Y = 65
  33.     For i = 3 To Cells(3, 1).End(xlDown).Row Step 2 '定義名稱
  34.         範圍名稱 = Chr(Y)
  35.         Names.Add Name:="第" & 範圍名稱 & "項", RefersTo:=Range(Cells(i, 1), Cells(i, 1).End(xlToRight))
  36.         Y = Y + 1
  37.     Next i
  38.    
  39.     Set AWN = ActiveWorkbook.Names '合併
  40.     For R = 1 To AWN.Count
  41.        If R <> 1 Then
  42.           K = Mid(AWN(R).RefersToR1C1Local, 2, Len(AWN(R))) & ","
  43.        Else
  44.           K = AWN(R).RefersToR1C1Local & ","
  45.        End If
  46.         U = U + K
  47.     Next R
  48.     Names.Add Name:="指定範圍", RefersTo:=Mid(U, 1, Len(U) - 1)
  49.    
  50.     For E = ActiveWorkbook.Names.Count To 1 Step -1 '清除定義名稱
  51.        If ActiveWorkbook.Names(E).Name <> "指定範圍" Then
  52.           ActiveWorkbook.Names(E).Delete
  53.        End If
  54.     Next E
  55.    
  56.    If Cells(1, 1) = "" Then
  57.       Cells(1, 1) = Cells(3, 1)
  58.    Else
  59.       Cells(1, 1) = Cells(1, 1)
  60.    End If
  61.    
  62.     D = Cells(1, 1)
  63.    
  64.     For Each G In Range("指定範圍") '周輪班
  65.     If G.Offset >= Cells(1, 1) Then
  66.         If Weekday(G) = 1 Or Weekday(G) = 7 Then '六日上色
  67.            G.Offset(-1, 0).Interior.Color = RGB(172, 199, 213)
  68.         End If
  69.    
  70.         K = G.Offset
  71.         
  72.         Select Case DateAdd("d", -1, K) Mod 6 + 1   '常日班
  73.         Case 1 To 4
  74.             G.Offset = "上班"
  75.             G.Offset.Font.Color = RGB(0, 0, 89)
  76.             G.Interior.Color = RGB(150, 201, 123)
  77.         Case 5 To 6
  78.             If G.Offset >= Cells(1, 1) Then
  79.             G.Offset = "休假"
  80.             G.Offset.Font.Color = RGB(114, 0, 55)
  81.             G.Offset.Interior.Color = RGB(255, 255, 92)
  82.             End If
  83.         End Select
  84.         
  85.         Select Case DateAdd("d", -1, K) Mod 12 + 1 '周輪班
  86.         Case 1 To 4
  87.             G.Offset = "夜班"
  88.             G.Offset.Font.Color = RGB(114, 0, 55)
  89.             G.Offset.Interior.Color = RGB(255, 208, 0)
  90.         Case 5 To 6
  91.         End Select
  92.         
  93.     End If
  94.     Next G
  95.    
  96. End Sub
複製代碼
作者: 軒云熊    時間: 2020-6-29 02:28

本帖最後由 軒云熊 於 2020-6-29 02:29 編輯

問題解決了 >"< 但是這寫法 並不是很好  
後來想出來的辦法是用 顏色 去做判斷
日期的計算 實在沒辦法...真的想不出來
再把最後的顏色數值先存到儲存格
更改下一年之後 再把顏色數值存回變數...
實在想不出辦法的辦法...  希望有更好的辦法
準提大大的版本 排版更是清楚　
但我應該在哪一段修改　要怎麼寫？
作者: n7822123    時間: 2020-6-30 00:37

本帖最後由 n7822123 於 2020-6-30 00:49 編輯

回復 20# 軒云熊


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

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

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

需求：

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

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

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

先開欄位吧~~如下圖

[attach]32238[/attach]


儲存格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
...
...
...

[attach]32240[/attach]
作者: n7822123    時間: 2020-6-30 02:23

回復 21# n7822123


哎! 看錯了，這行改一下

TN = Int((i - xDay + 1) / (xVD1 + xVD2))
作者: 軒云熊    時間: 2020-7-1 05:06

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

本帖最後由 軒云熊 於 2020-7-11 20:05 編輯

請問 有關於月輪班  跨月的部分問題
當一個月 的最後一輪 到 下個月的第一輪
該用怎麼樣的判斷方式 才可以完整的 把一整輪的天數輪完
而不會因為隔月的問題 導致 錯誤
嘗試了計數的方式 還是不行 會卡到月份問題 有的月份天數不一樣
請前輩們 幫幫忙
[attach]32273[/attach]
[attach]32274[/attach]
作者: 軒云熊    時間: 2020-7-12 21:00

問題解決了  謝謝準提大大的檔案 還有  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 '儲存延伸天數

  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
複製代碼
謝謝大大們的指導



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)