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

Sub Ex()
Dim 週表(), Ds As Object, 表單 As Range, R As Range
Dim Sh As Worksheet, f As Range, D As Date
週表 = Array("一", "二", "三", "四", "五", "六", "日") '星期別之陣列
Set Ds = CreateObject("Scripting.Dictionary")
With Sheets("總表") '指定在總表
Set 表單 = .[B5] '總表的第1個日期
D = DateValue(Split(.[B2], Space(1))(0)) 'B2:-> 2011/09 XXXX
For Each Sh In Sheets
If Sh.Name <> .Name Then '依序在平日,假日,周日等工作表
For Each R In Sh.UsedRange.Columns(3).Cells '第3欄
If R = Month(D) Then Ds(DateSerial(Year(D), R, R.Cells(1, 2))) = R.Cells(1, -1) 'R.Cells(1, -1): ->當日值班人員
'R = Month(D) 同一月份
Next
End If
Next
表單.Resize(31, 14) = "" '清除舊資料
Do While Month(D) = Month(DateValue(Split(.[B2], Space(1))(0))) '迴圈的條件是同一月份
Set f = .Cells.Find(Ds(D)) '尋找當日在表單裡值班人員的位置
.Cells(表單.Row, f.Column) = "●" 'f.Column: 值班人員位置的欄數
With 表單
.Cells = Day(D) '寫入日數
.Cells(1, 2) = 週表(Weekday(D, vbMonday) - 1) '寫入傳回星期別
.Resize(, 2).Interior.ColorIndex = IIf(Weekday(D, vbMonday) >= 6, 6, xlNone) '制訂休假日背景色
End With
Set 表單 = 表單.Offset(1) '往下位移一位
D = D + 1 '日期+1天
Loop
End With
Set Ds = Nothing
Set 表單 = Nothing
Set R = Nothing
Set Sh = Nothing
End Sub

複製代碼