n7822123

回復 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

軒云熊

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

n7822123

回復 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  

軒云熊

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

軒云熊

如果把  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

軒云熊

剛才在最後 多加一個迴圈 把文字跟顏色分開 就可以了 又是格式問題
感謝    準大大 和  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

軒云熊

子細看了 n7822123 大大的 Sub 玩日期 ()   發現
把外面再包一個 Int     D = Int(G.Offset)    就正常了不用多加迴圈  >"<

准提部林

公式+VBA:
練習日期v01.rar (23.29 KB)

下載次數: 8

2020-6-28 11:22

那"排班"--僅以 [上?休?] 來排, 不具實用性, 參考吧!

下載 (16.01 KB)

2020-6-28 11:24

軒云熊

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

以下是之前修改過的　但對我來說已經是極限了．．實在想不出來　＞＂＜
問題出在這裡：
如果用　＂ｗｗ＂　週數計算上班的天數就會有問題．．不知如何修改　
＂ｄ＂天數會搭不到　　
        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
   
10. 
    
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

複製代碼

軒云熊

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