返回列表 上一主題 發帖

[發問] 跳號輪值表

h60327

帖子
39 
主題
11 
精華
0 
積分
56 
點名
0  
作業系統
XP3 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2010-5-7 
最後登錄
2023-3-22 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-3-25 16:53 | 只看該作者

[發問] 跳號輪值表

後進之前有尋求板主協助完成一份輪值表，但因人員調整致輪值人員洽為5的倍數，若照表輪值則每人都會同一周期留守，因此需跳號輪值，例如第二周時第一個輪值人員跳過，第三周澤第二個輪值人員跳調，不知是否可透過程式完成。 ABC.rar (32.28 KB)

123.jpg (65.97 KB)

123.jpg

收藏 分享

linyancheng

帖子
228 
主題
73 
精華
2 
積分
333 
點名
0  
作業系統
Windows 10 
軟體版本
Office 2000, 2019 
閱讀權限
100 
性別
男 
來自
彰化縣 
註冊時間
2013-7-18 
最後登錄
2024-10-13 
2#
發表於 2014-3-25 20:12 | 只看該作者
打開觀看，已有程式碼了，不曉得問題在那？

TOP

h60327

帖子
39 
主題
11 
精華
0 
積分
56 
點名
0  
作業系統
XP3 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2010-5-7 
最後登錄
2023-3-22 

論壇贊助勳章
3#
發表於 2014-3-25 21:02 | 只看該作者
程式碼係順續跳號，例如由周一到周五連續循環，但為避免每人都在同一天(如周一)輪值，故需跳號第二循環時第1人跳過，如範例各顏色顯示狀況

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
4#
發表於 2014-4-8 16:23 | 只看該作者
本帖最後由 yen956 於 2014-4-8 16:24 編輯

一、建立整年度【平日輪班名單】暫存表, 供總表抓名單用
vba Code 如下：
  1. Option Explicit
  2. '排平日輪班表
  3. Private Sub CommandButton1_Click()
  4.     Dim i, rowA, 輪數 As Integer
  5.     Dim rng, cel As Range
  6.     MsgBox "將清除右表原有資料, 是否繼續?", vbYesNo
  7.    
  8.     Application.ScreenUpdating = False   '關閉螢幕刷新
  9.    
  10.     '去除格線, 以防 .End 誤判
  11.     [A:A].Borders.LineStyle = 0
  12.    
  13.     rowA = [A2].End(xlDown).Row
  14.    
  15.     '平日一年約260天, 以280天計
  16.     輪數 = (280 / (rowA - 1))
  17.    
  18.     '去除格線, 以防 .End 誤判
  19.     [G2].Resize(rowA, 輪數).Borders.LineStyle = 0
  20.    
  21.     '清除排班表
  22.     [G2].Resize(rowA + 20, 輪數 + 20) = ""
  23.    
  24.     '將 欄A 值日人員名單 複製到 欄G
  25.     [A2].Resize(rowA, 1).Copy [G2]
  26.    
  27.     For i = 1 To 輪數 - 1
  28.    
  29.         '將 當前欄 的 值日人員名單 複製到 後一欄
  30.         Cells(2, 6 + i).Resize(rowA, 1).Copy Cells(2, 7 + i)
  31.         
  32.         '根據 [D5](每輪跳幾號) 的值, 決定要剪下多少儲存格, 貼到最下面
  33.         Cells(2, 7 + i).Resize([D5], 1).Cut
  34.         Cells(rowA + 1, 7 + i).Insert Shift:=xlDown
  35.     Next
  36.    
  37.     Application.ScreenUpdating = True     '打開螢幕刷新
  38. End Sub
複製代碼
如下圖：

二、建立整年度【假日輪班名單】暫存表, 供總表抓名單用
但是, 這份名單在排序上正好上面相反,
才不會有人抱怨說, 怎麼老是從我開始排起,
vba Code 如下：
  1. Option Explicit
  2. '排假日輪班表
  3. Private Sub CommandButton1_Click()
  4.     Dim i, rowA, 輪數 As Integer
  5.    
  6.     MsgBox "將清除右表原有資料, 是否繼續?", vbYesNo
  7.    
  8.     Application.ScreenUpdating = False   '關閉螢幕刷新
  9.    
  10.     '去除格線, 以防 .End 誤判
  11.     [A:A].Borders.LineStyle = 0
  12.    
  13.     rowA = [A2].End(xlDown).Row
  14.    
  15.     '例假日一年約115天, 以120天計
  16.     輪數 = (120 / (rowA - 1))
  17.    
  18.     '去除格線, 以防 .End 誤判
  19.     [G2].Resize(rowA, 輪數).Borders.LineStyle = 0
  20.    
  21.     '清除排班表
  22.     [G2].Resize(rowA + 20, 輪數 + 20) = ""
  23.    
  24.     '將 欄A 值日人員名單【反向】複製到 欄G
  25.     For i = 2 To rowA
  26.         Cells(i, 1).Copy Cells(Abs(i - rowA) + 2, 7)
  27.     Next
  28.    
  29.     For i = 1 To 輪數 - 1
  30.    
  31.         '將 當前欄 值日人員名單 複製到 後一欄
  32.         Cells(2, 6 + i).Resize(rowA, 1).Copy Cells(2, 7 + i)
  33.         
  34.         '根據 [D5](每輪跳幾號) 的值, 決定要剪下多少儲存格, 貼到最下面
  35.         Cells(2, 7 + i).Resize([D5], 1).Cut
  36.         Cells(rowA + 1, 7 + i).Insert Shift:=xlDown
  37.     Next
  38.     '
  39.     Application.ScreenUpdating = True     '打開螢幕刷新
  40. End Sub
複製代碼
如下圖：

(未完)

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
5#
發表於 2014-4-9 09:27 | 只看該作者
回復 3# h60327
如何製作跳號輪值表(二)
三、上網抓現成的月曆表
如下圖：(你也可抓其他的月曆表, 例如：你可以抓內政部的「辦公日曆表」)
   
並修改成下列格式, 當作本軟體的總表
修改重點：
1. 將1到12月由上到下, 連續並排
2. 平日的【日期】字體色顏色為黑色, 假日為紅色或藍色
(與背景顏色無關)
3. 每月固定20列(含標題), 不足20列, 應補足20列
如下圖:

在總表中, 我們加入了下列功能：
(人事問題, 難免碰上這些問題)
A、處理離職人員
vba Code 如下：
  1. '處理離職人員
  2. Private Sub CommandButton2_Click()
  3.     Dim sh As Object, rng1, cel As Range
  4.     Dim sh1 As Worksheet
  5.    
  6.     Set sh1 = Sheets("總表")
  7.    
  8.     Application.ScreenUpdating = False          '關閉螢幕刷新
  9.    
  10.     sh1.[N8] = "=MATCH(RC[-1],x,0)+1"
  11.    
  12.     處理離職人員 "平日"
  13.     處理離職人員 "假日"
  14.    
  15.     '//////////////////////
  16.     '以下處理 臨時代班人員
  17.    
  18.     Set rng1 = sh1.Cells(sh1.[P4] * 20 - 16, 1).Resize(18, 7)
  19.    
  20.     '在當月值勤表上, 查找 離職人員 名單, 並傳給 cel
  21.     Set cel = rng1.Find(What:=sh1.[M8], LookIn:=xlValues, _
  22.         LookAt:=xlWhole)
  23.         
  24.     '如果當月值勤表上, 有找到 離職人員 名單
  25.     If Not cel Is Nothing Then
  26.    
  27.         If cel.Offset(-2, 0).Font.ColorIndex = 1 Then
  28.             Set sh = Sheets("平日")
  29.         Else
  30.             Set sh = Sheets("假日")
  31.         End If
  32.         
  33.         '如果 [G2] 及 [H2] 均為空白, 表示已無暫存名單可用
  34.         If sh.[G2] = "" And sh.[H2] = "" Then
  35.             MsgBox "無暫存名單可用!!", vbExclamation
  36.             Exit Sub
  37.         End If
  38.         
  39.         '若 [G2] 為空白格(則 欄G 為空白欄), 而 [H2] 不是空白格, 則
  40.         If sh.[G2] = "" And sh.[H2] <> "" Then
  41.                         
  42.             '刪除 欄G, 並向左移(取得 欄H 的名單)
  43.             sh.[G2].Resize(rowA, 1).Delete Shift:=xlToLeft
  44.         End If
  45.         
  46.         '將[G2]複製到 總表的儲存格 cel
  47.         sh.[G2].Copy
  48.         cel.PasteSpecial Paste:=xlPasteValues
  49.             
  50.         '也複製到 總表的 sh1.[M12], 用以提醒管理人員 通知 臨時代班人員
  51.         sh.[G2].Copy
  52.         sh1.[M12].PasteSpecial Paste:=xlPasteValues
  53.                         
  54.         '並將 [G2] 刪除且向上移一格
  55.         sh.[G2].Delete xlUp
  56.     End If
  57.     Application.ScreenUpdating = True     '打開螢幕刷新
  58. End Sub
複製代碼
  1. '處理離職人員副程式
  2. Sub 處理離職人員(ByVal name1 As String)
  3.     Dim sh, sh1 As Worksheet
  4.     Dim r1, rowA, col1 As Integer
  5.     Dim rng As Range, str1 As String
  6.    
  7.     Set sh1 = Sheets("總表")
  8.     Set sh = Sheets(name1)
  9.     Application.ScreenUpdating = False       '關閉螢幕刷新
  10.    
  11.     sh.[A:A].Borders.LineStyle = 0
  12.    
  13.     '//////////////////////
  14.     '以下刪除 欄A 的 離職人員名單
  15.     '取得 欄A 最下面非空白格 的列號
  16.     rowA = sh.[A2].End(xlDown).Row + 20
  17.    
  18.     '重新定義 match 欲搜尋的範圍
  19.     ActiveWorkbook.Names("x").Delete
  20.     ActiveWorkbook.Names.Add Name:="x", RefersToR1C1:="=" & name1 & "!R2C1:R" & rowA & "C1"
  21.    
  22.     '若 Match 成功, 則 sh1.[N8] 是目標的列號
  23.     If Application.IsNumber(sh1.[N8]) Then
  24.    
  25.         '刪除 搜尋目標(離職人員名單), 並向上移一格
  26.         sh.Cells(sh1.[N8], 1).Delete Shift:=xlUp
  27.         
  28.         '//////////////////////
  29.         '以下刪除 欄G、欄H... 的 離職人員名單
  30.         col1 = 7
  31.         Do
  32.             If sh.Cells(2, col1) <> "" Then
  33.                      
  34.                 If Application.IsNumber(sh1.[N8]) Then
  35.                     sh.Cells(sh1.[N8], col1).Delete Shift:=xlUp
  36.                 End If
  37.             End If
  38.             col1 = col1 + 1
  39.         Loop Until sh.Cells(2, col1) = ""
  40.     Else
  41.         MsgBox "找不到【" & sh1.[M8] & "】" & Chr(10) _
  42.              & "請查明再做!!", vbExclamation
  43.     End If
  44. End Sub
複製代碼
B、處理新進人員
vba Code 如下：
  1. '處理新進人員
  2. Sub 處理新進人員(ByVal name1 As String)
  3.     Dim sh, sh1 As Worksheet
  4.     Dim c1, rowA, col1 As Integer
  5.     Dim rng As Range, str1, 前後 As String
  6.    
  7.     Set sh1 = Sheets("總表")
  8.     Set sh = Sheets(name1)
  9.    
  10.     Application.ScreenUpdating = False       '關閉螢幕刷新
  11.    
  12.     '清除格線, 以免 .End 誤判
  13.     sh.[A:A].Borders.LineStyle = 0
  14.     sh.[2:2].Borders.LineStyle = 0

  16.     前後 = sh1.[O21]
  17.    
  18.     col1 = sh.[IV2].End(xlToLeft).Column
  19.     If col1 < 7 Then col1 = 7
  20.    
  21.     If 前後 = "最前面" Then
  22.    
  23.         '用插入的方式, 將新進人員, 插入 sh.[A2]
  24.         sh1.[M18].Copy: sh.[A2].Insert Shift:=xlDown
  25.             
  26.         For c1 = 7 To col1
  27.             sh1.[M18].Copy: sh.Cells(2, c1).Insert Shift:=xlDown
  28.         Next
  29.         
  30.     Else
  31.         '將 新進人員 放到 各欄 的最下面
  32.         rowA = sh.[A2].End(xlDown).Row + 1
  33.         sh.Cells(rowA, 1) = sh1.[M18]
  34.         
  35.         For c1 = 7 To col1
  36.             rowA = sh.Cells(2, c1).End(xlDown).Row + 1
  37.             sh.Cells(rowA, c1) = sh1.[M18]
  38.         Next
  39.         
  40.     End If
  41.     Application.ScreenUpdating = True        '打開螢幕刷新
  42. End Sub
複製代碼
C、處理臨時代班人員
vba Code 如下：
  1. '處理臨時代班
  2. Private Sub CommandButton1_Click()
  3.     Dim sh As Object, rng1, cel As Range
  4.     Dim rowA As Integer
  5.     Dim sh1 As Worksheet
  6.    
  7.     Set sh1 = Sheets("總表")
  8.    
  9.     Application.ScreenUpdating = False          '關閉螢幕刷新
  10.    
  11.     Set rng1 = sh1.Cells(sh1.[P30] * 20 - 16, 1).Resize(18, 7)
  12.    
  13.     '在當月值勤表上, 查找 離職人員 名單, 並傳給 cel
  14.     Set cel = rng1.Find(What:=sh1.[M34], LookIn:=xlValues, _
  15.         LookAt:=xlWhole)
  16.         
  17.     '如果當月值勤表上, 有找到 離職人員 名單
  18.     If Not cel Is Nothing Then
  19.    
  20.         If cel.Offset(-2, 0).Font.ColorIndex = 1 Then
  21.             Set sh = Sheets("平日")
  22.         Else
  23.             Set sh = Sheets("假日")
  24.         End If
  25.         
  26.         '如果 [G2] 及 [H2] 均為空白, 表示已無暫存名單可用
  27.         If sh.[G2] = "" And sh.[H2] = "" Then
  28.             MsgBox "無暫存名單可用!!", vbExclamation
  29.             Exit Sub
  30.         End If
  31.         
  32.         '若 [G2] 為空白格(則 欄G 為空白欄), 而 [H2] 不是空白格, 則
  33.         If sh.[G2] = "" And sh.[H2] <> "" Then
  34.                         
  35.             '刪除 欄G, 並向左移(取得 欄H 的名單)
  36.             sh.[G2].Resize(rowA, 1).Delete Shift:=xlToLeft
  37.         End If
  38.         
  39.         '將[G2]複製到 總表的儲存格 cel
  40.         sh.[G2].Copy
  41.         cel.PasteSpecial Paste:=xlPasteValues
  42.             
  43.         '也複製到 總表的 sh1.[M12], 用以提醒管理人員 通知 臨時代班人員
  44.         sh.[G2].Copy
  45.         sh1.[M37].PasteSpecial Paste:=xlPasteValues
  46.                         
  47.         '並將 [G2] 刪除且向上移一格
  48.         sh.[G2].Delete xlUp
  49.     Else
  50.         MsgBox "" & [P30] & "月份值班表上, 查無【" & [M34] & "】此人," & Chr(10) & Chr(10) _
  51.                 & "請查明再繼續!!", vbExclamation
  52.     End If
  53.     Application.ScreenUpdating = True     '打開螢幕刷新
  54. End Sub
複製代碼
(未完)

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
6#
發表於 2014-4-9 19:28 | 只看該作者
回復 5# yen956
處理離職人員副程式
修正如下：
'處理離職人員副程式
Sub 處理離職人員(ByVal name1 As String)
    Dim sh, sh1 As Worksheet
    Dim r1, rowA, col1 As Integer
    Dim rng As Range, str1 As String
   
    Set sh1 = Sheets("總表")
    Set sh = Sheets(name1)
'    Application.ScreenUpdating = False       '關閉螢幕刷新
   
    sh.[A:A].Borders.LineStyle = 0
   
    '//////////////////////
    '以下刪除 欄A 的 離職人員名單
    '取得 欄A 最下面非空白格 的列號
    rowA = sh.[A2].End(xlDown).Row + 20
   
    '重新定義 match 欲搜尋的範圍
    ActiveWorkbook.Names("x").Delete
    ActiveWorkbook.Names.Add Name:="x", RefersToR1C1:="=" & name1 & "!R2C1:R" & rowA & "C1"
   
    '若 Match 成功, 則 sh1.[N8] 是目標的列號
    If Application.IsNumber(sh1.[N8]) Then
   
        '刪除 搜尋目標(離職人員名單), 並向上移一格
        sh.Cells(sh1.[N8], 1).Delete Shift:=xlUp
        
        '//////////////////////
        '以下刪除 欄G、欄H... 的 離職人員名單
        col1 = 7
        Do
            If sh.Cells(2, col1) <> "" Then
                '重新定義 match 欲搜尋的範圍
                ActiveWorkbook.Names("x").Delete
                ActiveWorkbook.Names.Add Name:="x", RefersToR1C1:="=" & name1 & "!R2C" & col1 & ":R" & rowA & "C" & col1 & ""
                     
                If Application.IsNumber(sh1.[N8]) Then
                    sh.Cells(sh1.[N8], col1).Delete Shift:=xlUp
                End If
            End If
            col1 = col1 + 1
        Loop Until sh.Cells(2, col1) = ""
    End If
End Sub

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
7#
發表於 2014-4-9 19:50 | 只看該作者
回復 3# h60327
如何製作跳號輪值表(完)
四、最後還有一個問題要處理,
那就是【連續假日】要不要連排同一人?
如果【連續假日要連排同一人】,
則要再增加一張工作表→【日期表】,
即將原月曆表(總表), 轉錄成【日柱】, 以方便VBA存取,
【建立日期表】的VBA Code 如下：
  1. '建立日期表
  2. '將【總表】的 月曆 轉換成【日期表】的日柱
  3. Private Sub CommandButton1_Click()
  4.     Dim sh1, sh2 As Worksheet
  5.     Dim 年, 月, i, j, k As Integer
  6.    
  7.     Set sh1 = Sheets("總表")
  8.     Set sh2 = Sheets("日期表")
  9.    
  10.     Application.ScreenUpdating = False   '關閉螢幕刷新
  11.    
  12.     '從【總表】的【月曆表】取得 年(西元), 並存入 sh2.[A2]
  13.     sh2.[A2] = "=MID(總表!A2,3,4)"
  14.    
  15.     k = 1
  16.     For 月 = 1 To 12
  17.         
  18.         '月曆表上, 每月有 6 週(包括空白格)
  19.         For i = 1 To 6
  20.         
  21.            '月曆表上, 每週有 7 天
  22.             For j = 1 To 7
  23.             
  24.                 '如果月曆表上是空白格, 換下一格
  25.                 If sh1.Cells(月 * 20 + i * 3 - 19, j) <> "" Then
  26.                
  27.                     k = k + 1
  28.                
  29.                     sh2.Cells(k, 2) = 月
  30.                     sh1.Cells(月 * 20 + i * 3 - 19, j).Copy sh2.Cells(k, 3)
  31.                     sh1.Cells(月 * 20 + i * 3 - 18, j).Copy sh2.Cells(k, 4)
  32.                     sh2.Cells(k, 5) = DateSerial(sh2.[A2], 月, sh2.Cells(k, 3))
  33.                     sh2.Cells(k, 6) = sh2.Cells(k, 5)
  34.                     
  35.                 End If
  36.             Next
  37.         Next
  38.     Next
  39.     sh2.[A1].Resize(367, 7).Font.Size = 12
  40.     sh2.[A1].Resize(367, 7).Borders.LineStyle = 0
  41.     Application.ScreenUpdating = True     '打開螢幕刷新
  42. End Sub
複製代碼
如下圖：

最後再加上
A、排輪值表(連續假日連排同一人)
vba Code 如下：
  1. '副程式
  2. Sub 複製名單到日期表(ByVal name1 As String, ByVal k As Integer)
  3.     Dim sh, sh2 As Object
  4.     Set sh = Sheets(name1)
  5.     Set sh2 = Sheets("日期表")
  6.    
  7.     '若 [G2] 為空白格(則 欄G 為空白欄), 而 [H2] 不是空白格, 則
  8.     If sh.[G2] = "" Then
  9.             
  10.         '刪除 欄G, 並向左移(取得 欄H 的名單)
  11.         sh.[G2].Resize(row3, 1).Delete Shift:=xlToLeft
  12.     End If
  13.             
  14.     '將[G2]複製到 日期表
  15.     sh.[G2].Copy
  16.     sh2.Cells(k, 7).PasteSpecial Paste:=xlPasteValues
  17.             
  18.     '並將 [G2] 刪除且向上移一格
  19.     sh.[G2].Delete xlUp
  20. End Sub

  22. '副程式
  23. Sub 從日期表複製名單到總表()
  24.     Dim sh1, sh2 As Object
  25.     Dim i, j, k As Integer
  26.     Dim cel As Range
  27.    
  28.     Set sh1 = Sheets("總表")
  29.     Set sh2 = Sheets("日期表")
  30.    
  31.     '【日期表】中, 欲複製到【總表】的名單 的 始列號
  32.     k = sh2.[J14]
  33.    
  34.     '從 日期表 複製到 總表
  35.     For i = 1 To 6
  36.         For j = 1 To 7
  37.         
  38.             Set cel = sh1.Cells(sh2.[J13] * 20 + i * 3 - 19, j)
  39.             
  40.             '若日期 = "", 則換下一個
  41.             If cel <> "" Then
  42.                
  43.                 cel.Offset(2, 0) = sh2.Cells(k, 7)
  44.             End If
  45.             
  46.             k = k + 1
  47.         Next
  48.     Next i
  49. End Sub
複製代碼
  1. '排輪值表(連續假日連排同一人)
  2. Private Sub CommandButton2_Click()
  3.     Dim sh1, sh2, sh3, sh4 As Object
  4.     Dim i, j, k, row3, row4 As Integer
  5.     Dim cel As Range
  6.    
  7.     Set sh1 = Sheets("總表")
  8.     Set sh2 = Sheets("日期表")
  9.     Set sh3 = Sheets("平日")
  10.     Set sh4 = Sheets("假日")
  11.    
  12.     '若 [G2] 及 [H2] 皆為空白格, 則
  13.     If sh4.[G2] = "" And sh4.[H2] = "" Then
  14.         MsgBox "已無名單可用", vbExclamation
  15.         Exit Sub
  16.     End If
  17.    
  18.     Application.ScreenUpdating = False      '關閉螢幕刷新
  19.    
  20.     row3 = sh3.[A2].End(xlDown).Row
  21.     row4 = sh4.[A2].End(xlDown).Row
  22.    
  23.     'sh2.[J14] 直接指向【日期表】指定月份的 開始列號
  24.     sh2.[J14] = "=MATCH(J13,B2:B367,0) + 1"
  25.     k = sh2.[J14]
  26.    
  27.     Do
  28.         
  29.         '處理平日
  30.         If sh2.Cells(k, 3).Font.ColorIndex = 1 Then
  31.         
  32.             複製名單到日期表 "平日", k
  33.             
  34.         '處理假日
  35.         Else
  36.         
  37.             '如果 前一天 也是 假日, 則從前一天的名單 複製名單
  38.             If sh2.Cells(k - 1, 3).Font.ColorIndex = 3 _
  39.                    Or sh2.Cells(k - 1, 3).Font.ColorIndex = 5 Then
  40.             
  41.                 If sh2.Cells(k - 1, 7) <> "" Then
  42.                     sh2.Cells(k, 7) = sh2.Cells(k - 1, 7)
  43.                     
  44.                 '但, 如果 前一天的 名單 是空白, 則自 "假日" 表中, 複製名單
  45.                 Else
  46.                     複製名單到日期表 "假日", k
  47.                 End If
  48.                
  49.             '否則, 自 "假日" 表中, 複製名單
  50.             Else
  51.                 複製名單到日期表 "假日", k
  52.             End If
  53.         End If
  54.         
  55.         k = k + 1

  57.     Loop Until sh2.Cells(k, 2) > sh2.[J13]
  58.    
  59.     從日期表複製名單到總表
  60.    
  61.     Application.ScreenUpdating = True          '打開螢幕刷新
  62. End Sub
複製代碼
B、排輪值表(連續假日不連排同一人)
vba Code 如下：
  1. '排輪值表(連續假日不連排同一人)
  2. Private Sub CommandButton3_Click()
  3.     Dim sh1, sh2, sh3, sh4 As Object
  4.     Dim i, j, k, row3, row4 As Integer
  5.     Dim cel As Range
  6.    
  7.     Set sh1 = Sheets("總表")
  8.     Set sh2 = Sheets("日期表")
  9.     Set sh3 = Sheets("平日")
  10.     Set sh4 = Sheets("假日")
  11.    
  12.     '若 [G2] 及 [H2] 皆為空白格, 則
  13.     If sh4.[G2] = "" And sh4.[H2] = "" Then
  14.         MsgBox "已無名單可用", vbExclamation
  15.         Exit Sub
  16.     End If
  17.    
  18.     Application.ScreenUpdating = False      '關閉螢幕刷新
  19.    
  20.     row3 = sh3.[A2].End(xlDown).Row
  21.     row4 = sh4.[A2].End(xlDown).Row
  22.    
  23.     'sh2.[J14] 直接指向【日期表】指定月份的 開始列號
  24.     sh2.[J14] = "=MATCH(J13,B2:B367,0) + 1"
  25.     k = sh2.[J14]
  26.    
  27.     Do
  28.         
  29.         '若 ColorIndex = 1, 則自【平日】表中, 複製名單 到【日期表】
  30.         If sh2.Cells(k, 3).Font.ColorIndex = 1 Then
  31.         
  32.             複製名單到日期表 "平日", k
  33.             
  34.         '否則, 自【假日】表中, 複製名單 到【日期表】
  35.         Else
  36.         
  37.             複製名單到日期表 "假日", k
  38.         End If
  39.         
  40.         k = k + 1

  42.     Loop Until sh2.Cells(k, 2) > sh2.[J13]
  43.    
  44.     從日期表複製名單到總表
  45.    
  46.     Application.ScreenUpdating = True          '打開螢幕刷新
  47. End Sub
複製代碼
OK, 大功告成, 可以測試去了。
不想自己動手的朋友, 這裡有一個現成的檔案,
可下載來試試看：
http://www.mediafire.com/download/6ibnow9d2rk851g/%E8%B7%B3%E8%99%9F%E8%BC%AA%E5%80%BC%E8%A1%A8.7z
順便幫忙測試, 謝謝!!

TOP

        靜思自在 : 做該做的事是智慧，做不該做的事是愚癡。
返回列表 上一主題