麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 跳號輪值表 [打印本頁]

作者: h60327 時間: 2014-3-25 16:53 標題: 跳號輪值表

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

作者: linyancheng 時間: 2014-3-25 20:12

打開觀看，已有程式碼了，不曉得問題在那？

作者: h60327 時間: 2014-3-25 21:02

程式碼係順續跳號，例如由周一到周五連續循環，但為避免每人都在同一天(如周一)輪值，故需跳號第二循環時第1人跳過，如範例各顏色顯示狀況

作者: yen956 時間: 2014-4-8 16:23

本帖最後由 yen956 於 2014-4-8 16:24 編輯

一、建立整年度【平日輪班名單】暫存表, 供總表抓名單用
vba Code 如下：

Option Explicit
'排平日輪班表
Private Sub CommandButton1_Click()
Dim i, rowA, 輪數 As Integer
Dim rng, cel As Range
MsgBox "將清除右表原有資料, 是否繼續?", vbYesNo
Application.ScreenUpdating = False '關閉螢幕刷新
'去除格線, 以防 .End 誤判
[A:A].Borders.LineStyle = 0
rowA = [A2].End(xlDown).Row
'平日一年約260天, 以280天計
輪數 = (280 / (rowA - 1))
'去除格線, 以防 .End 誤判
[G2].Resize(rowA, 輪數).Borders.LineStyle = 0
'清除排班表
[G2].Resize(rowA + 20, 輪數 + 20) = ""
'將欄A 值日人員名單複製到欄G
[A2].Resize(rowA, 1).Copy [G2]
For i = 1 To 輪數 - 1
'將當前欄的值日人員名單複製到後一欄
Cells(2, 6 + i).Resize(rowA, 1).Copy Cells(2, 7 + i)
'根據 [D5](每輪跳幾號) 的值, 決定要剪下多少儲存格, 貼到最下面
Cells(2, 7 + i).Resize([D5], 1).Cut
Cells(rowA + 1, 7 + i).Insert Shift:=xlDown
Next
Application.ScreenUpdating = True '打開螢幕刷新
End Sub

複製代碼

如下圖：

二、建立整年度【假日輪班名單】暫存表, 供總表抓名單用
但是, 這份名單在排序上正好上面相反,
才不會有人抱怨說, 怎麼老是從我開始排起,
vba Code 如下：

Option Explicit
'排假日輪班表
Private Sub CommandButton1_Click()
Dim i, rowA, 輪數 As Integer
MsgBox "將清除右表原有資料, 是否繼續?", vbYesNo
Application.ScreenUpdating = False '關閉螢幕刷新
'去除格線, 以防 .End 誤判
[A:A].Borders.LineStyle = 0
rowA = [A2].End(xlDown).Row
'例假日一年約115天, 以120天計
輪數 = (120 / (rowA - 1))
'去除格線, 以防 .End 誤判
[G2].Resize(rowA, 輪數).Borders.LineStyle = 0
'清除排班表
[G2].Resize(rowA + 20, 輪數 + 20) = ""
'將欄A 值日人員名單【反向】複製到欄G
For i = 2 To rowA
Cells(i, 1).Copy Cells(Abs(i - rowA) + 2, 7)
Next
For i = 1 To 輪數 - 1
'將當前欄值日人員名單複製到後一欄
Cells(2, 6 + i).Resize(rowA, 1).Copy Cells(2, 7 + i)
'根據 [D5](每輪跳幾號) 的值, 決定要剪下多少儲存格, 貼到最下面
Cells(2, 7 + i).Resize([D5], 1).Cut
Cells(rowA + 1, 7 + i).Insert Shift:=xlDown
Next
'
Application.ScreenUpdating = True '打開螢幕刷新
End Sub

複製代碼

如下圖：

(未完)

作者: yen956 時間: 2014-4-9 09:27

回復 3# h60327
如何製作跳號輪值表(二)
三、上網抓現成的月曆表
如下圖：(你也可抓其他的月曆表, 例如：你可以抓內政部的「辦公日曆表」)

並修改成下列格式, 當作本軟體的總表
修改重點：
1. 將1到12月由上到下, 連續並排
2. 平日的【日期】字體色顏色為黑色, 假日為紅色或藍色
(與背景顏色無關)
3. 每月固定20列(含標題), 不足20列, 應補足20列
如下圖:

在總表中, 我們加入了下列功能：
(人事問題, 難免碰上這些問題)
A、處理離職人員
vba Code 如下：

'處理離職人員
Private Sub CommandButton2_Click()
Dim sh As Object, rng1, cel As Range
Dim sh1 As Worksheet
Set sh1 = Sheets("總表")
Application.ScreenUpdating = False '關閉螢幕刷新
sh1.[N8] = "=MATCH(RC[-1],x,0)+1"
處理離職人員 "平日"
處理離職人員 "假日"
'//////////////////////
'以下處理臨時代班人員
Set rng1 = sh1.Cells(sh1.[P4] * 20 - 16, 1).Resize(18, 7)
'在當月值勤表上, 查找離職人員名單, 並傳給 cel
Set cel = rng1.Find(What:=sh1.[M8], LookIn:=xlValues, _
LookAt:=xlWhole)
'如果當月值勤表上, 有找到離職人員名單
If Not cel Is Nothing Then
If cel.Offset(-2, 0).Font.ColorIndex = 1 Then
Set sh = Sheets("平日")
Else
Set sh = Sheets("假日")
End If
'如果 [G2] 及 [H2] 均為空白, 表示已無暫存名單可用
If sh.[G2] = "" And sh.[H2] = "" Then
MsgBox "無暫存名單可用!!", vbExclamation
Exit Sub
End If
'若 [G2] 為空白格(則欄G 為空白欄), 而 [H2] 不是空白格, 則
If sh.[G2] = "" And sh.[H2] <> "" Then
'刪除欄G, 並向左移(取得欄H 的名單)
sh.[G2].Resize(rowA, 1).Delete Shift:=xlToLeft
End If
'將[G2]複製到總表的儲存格 cel
sh.[G2].Copy
cel.PasteSpecial Paste:=xlPasteValues
'也複製到總表的 sh1.[M12], 用以提醒管理人員通知臨時代班人員
sh.[G2].Copy
sh1.[M12].PasteSpecial Paste:=xlPasteValues
'並將 [G2] 刪除且向上移一格
sh.[G2].Delete xlUp
End If
Application.ScreenUpdating = True '打開螢幕刷新
End Sub

複製代碼

'處理離職人員副程式
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
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) = ""
Else
MsgBox "找不到【" & sh1.[M8] & "】" & Chr(10) _
& "請查明再做!!", vbExclamation
End If
End Sub

複製代碼

B、處理新進人員
vba Code 如下：

'處理新進人員
Sub 處理新進人員(ByVal name1 As String)
Dim sh, sh1 As Worksheet
Dim c1, rowA, col1 As Integer
Dim rng As Range, str1, 前後 As String
Set sh1 = Sheets("總表")
Set sh = Sheets(name1)
Application.ScreenUpdating = False '關閉螢幕刷新
'清除格線, 以免 .End 誤判
sh.[A:A].Borders.LineStyle = 0
sh.[2:2].Borders.LineStyle = 0
前後 = sh1.[O21]
col1 = sh.[IV2].End(xlToLeft).Column
If col1 < 7 Then col1 = 7
If 前後 = "最前面" Then
'用插入的方式, 將新進人員, 插入 sh.[A2]
sh1.[M18].Copy: sh.[A2].Insert Shift:=xlDown
For c1 = 7 To col1
sh1.[M18].Copy: sh.Cells(2, c1).Insert Shift:=xlDown
Next
Else
'將新進人員放到各欄的最下面
rowA = sh.[A2].End(xlDown).Row + 1
sh.Cells(rowA, 1) = sh1.[M18]
For c1 = 7 To col1
rowA = sh.Cells(2, c1).End(xlDown).Row + 1
sh.Cells(rowA, c1) = sh1.[M18]
Next
End If
Application.ScreenUpdating = True '打開螢幕刷新
End Sub

複製代碼

C、處理臨時代班人員
vba Code 如下：

'處理臨時代班
Private Sub CommandButton1_Click()
Dim sh As Object, rng1, cel As Range
Dim rowA As Integer
Dim sh1 As Worksheet
Set sh1 = Sheets("總表")
Application.ScreenUpdating = False '關閉螢幕刷新
Set rng1 = sh1.Cells(sh1.[P30] * 20 - 16, 1).Resize(18, 7)
'在當月值勤表上, 查找離職人員名單, 並傳給 cel
Set cel = rng1.Find(What:=sh1.[M34], LookIn:=xlValues, _
LookAt:=xlWhole)
'如果當月值勤表上, 有找到離職人員名單
If Not cel Is Nothing Then
If cel.Offset(-2, 0).Font.ColorIndex = 1 Then
Set sh = Sheets("平日")
Else
Set sh = Sheets("假日")
End If
'如果 [G2] 及 [H2] 均為空白, 表示已無暫存名單可用
If sh.[G2] = "" And sh.[H2] = "" Then
MsgBox "無暫存名單可用!!", vbExclamation
Exit Sub
End If
'若 [G2] 為空白格(則欄G 為空白欄), 而 [H2] 不是空白格, 則
If sh.[G2] = "" And sh.[H2] <> "" Then
'刪除欄G, 並向左移(取得欄H 的名單)
sh.[G2].Resize(rowA, 1).Delete Shift:=xlToLeft
End If
'將[G2]複製到總表的儲存格 cel
sh.[G2].Copy
cel.PasteSpecial Paste:=xlPasteValues
'也複製到總表的 sh1.[M12], 用以提醒管理人員通知臨時代班人員
sh.[G2].Copy
sh1.[M37].PasteSpecial Paste:=xlPasteValues
'並將 [G2] 刪除且向上移一格
sh.[G2].Delete xlUp
Else
MsgBox "" & [P30] & "月份值班表上, 查無【" & [M34] & "】此人," & Chr(10) & Chr(10) _
& "請查明再繼續!!", vbExclamation
End If
Application.ScreenUpdating = True '打開螢幕刷新
End Sub

複製代碼

(未完)

作者: yen956 時間: 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

作者: yen956 時間: 2014-4-9 19:50

回復 3# h60327
如何製作跳號輪值表(完)
四、最後還有一個問題要處理,
那就是【連續假日】要不要連排同一人?
如果【連續假日要連排同一人】,
則要再增加一張工作表→【日期表】,
即將原月曆表(總表), 轉錄成【日柱】, 以方便VBA存取,
【建立日期表】的VBA Code 如下：

'建立日期表
'將【總表】的月曆轉換成【日期表】的日柱
Private Sub CommandButton1_Click()
Dim sh1, sh2 As Worksheet
Dim 年, 月, i, j, k As Integer
Set sh1 = Sheets("總表")
Set sh2 = Sheets("日期表")
Application.ScreenUpdating = False '關閉螢幕刷新
'從【總表】的【月曆表】取得年(西元), 並存入 sh2.[A2]
sh2.[A2] = "=MID(總表!A2,3,4)"
k = 1
For 月 = 1 To 12
'月曆表上, 每月有 6 週(包括空白格)
For i = 1 To 6
'月曆表上, 每週有 7 天
For j = 1 To 7
'如果月曆表上是空白格, 換下一格
If sh1.Cells(月 * 20 + i * 3 - 19, j) <> "" Then
k = k + 1
sh2.Cells(k, 2) = 月
sh1.Cells(月 * 20 + i * 3 - 19, j).Copy sh2.Cells(k, 3)
sh1.Cells(月 * 20 + i * 3 - 18, j).Copy sh2.Cells(k, 4)
sh2.Cells(k, 5) = DateSerial(sh2.[A2], 月, sh2.Cells(k, 3))
sh2.Cells(k, 6) = sh2.Cells(k, 5)
End If
Next
Next
Next
sh2.[A1].Resize(367, 7).Font.Size = 12
sh2.[A1].Resize(367, 7).Borders.LineStyle = 0
Application.ScreenUpdating = True '打開螢幕刷新
End Sub

複製代碼

如下圖：

最後再加上
A、排輪值表(連續假日連排同一人)
vba Code 如下：

'副程式
Sub 複製名單到日期表(ByVal name1 As String, ByVal k As Integer)
Dim sh, sh2 As Object
Set sh = Sheets(name1)
Set sh2 = Sheets("日期表")
'若 [G2] 為空白格(則欄G 為空白欄), 而 [H2] 不是空白格, 則
If sh.[G2] = "" Then
'刪除欄G, 並向左移(取得欄H 的名單)
sh.[G2].Resize(row3, 1).Delete Shift:=xlToLeft
End If
'將[G2]複製到日期表
sh.[G2].Copy
sh2.Cells(k, 7).PasteSpecial Paste:=xlPasteValues
'並將 [G2] 刪除且向上移一格
sh.[G2].Delete xlUp
End Sub
'副程式
Sub 從日期表複製名單到總表()
Dim sh1, sh2 As Object
Dim i, j, k As Integer
Dim cel As Range
Set sh1 = Sheets("總表")
Set sh2 = Sheets("日期表")
'【日期表】中, 欲複製到【總表】的名單的始列號
k = sh2.[J14]
'從日期表複製到總表
For i = 1 To 6
For j = 1 To 7
Set cel = sh1.Cells(sh2.[J13] * 20 + i * 3 - 19, j)
'若日期 = "", 則換下一個
If cel <> "" Then
cel.Offset(2, 0) = sh2.Cells(k, 7)
End If
k = k + 1
Next
Next i
End Sub

複製代碼

'排輪值表(連續假日連排同一人)
Private Sub CommandButton2_Click()
Dim sh1, sh2, sh3, sh4 As Object
Dim i, j, k, row3, row4 As Integer
Dim cel As Range
Set sh1 = Sheets("總表")
Set sh2 = Sheets("日期表")
Set sh3 = Sheets("平日")
Set sh4 = Sheets("假日")
'若 [G2] 及 [H2] 皆為空白格, 則
If sh4.[G2] = "" And sh4.[H2] = "" Then
MsgBox "已無名單可用", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False '關閉螢幕刷新
row3 = sh3.[A2].End(xlDown).Row
row4 = sh4.[A2].End(xlDown).Row
'sh2.[J14] 直接指向【日期表】指定月份的開始列號
sh2.[J14] = "=MATCH(J13,B2:B367,0) + 1"
k = sh2.[J14]
Do
'處理平日
If sh2.Cells(k, 3).Font.ColorIndex = 1 Then
複製名單到日期表 "平日", k
'處理假日
Else
'如果前一天也是假日, 則從前一天的名單複製名單
If sh2.Cells(k - 1, 3).Font.ColorIndex = 3 _
Or sh2.Cells(k - 1, 3).Font.ColorIndex = 5 Then
If sh2.Cells(k - 1, 7) <> "" Then
sh2.Cells(k, 7) = sh2.Cells(k - 1, 7)
'但, 如果前一天的名單是空白, 則自 "假日" 表中, 複製名單
Else
複製名單到日期表 "假日", k
End If
'否則, 自 "假日" 表中, 複製名單
Else
複製名單到日期表 "假日", k
End If
End If
k = k + 1
Loop Until sh2.Cells(k, 2) > sh2.[J13]
從日期表複製名單到總表
Application.ScreenUpdating = True '打開螢幕刷新
End Sub

複製代碼

B、排輪值表(連續假日不連排同一人)
vba Code 如下：

'排輪值表(連續假日不連排同一人)
Private Sub CommandButton3_Click()
Dim sh1, sh2, sh3, sh4 As Object
Dim i, j, k, row3, row4 As Integer
Dim cel As Range
Set sh1 = Sheets("總表")
Set sh2 = Sheets("日期表")
Set sh3 = Sheets("平日")
Set sh4 = Sheets("假日")
'若 [G2] 及 [H2] 皆為空白格, 則
If sh4.[G2] = "" And sh4.[H2] = "" Then
MsgBox "已無名單可用", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False '關閉螢幕刷新
row3 = sh3.[A2].End(xlDown).Row
row4 = sh4.[A2].End(xlDown).Row
'sh2.[J14] 直接指向【日期表】指定月份的開始列號
sh2.[J14] = "=MATCH(J13,B2:B367,0) + 1"
k = sh2.[J14]
Do
'若 ColorIndex = 1, 則自【平日】表中, 複製名單到【日期表】
If sh2.Cells(k, 3).Font.ColorIndex = 1 Then
複製名單到日期表 "平日", k
'否則, 自【假日】表中, 複製名單到【日期表】
Else
複製名單到日期表 "假日", k
End If
k = k + 1
Loop Until sh2.Cells(k, 2) > sh2.[J13]
從日期表複製名單到總表
Application.ScreenUpdating = True '打開螢幕刷新
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
順便幫忙測試, 謝謝!!

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