- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2011-9-10 17:38
| 只看該作者
本帖最後由 GBKEE 於 2011-9-10 19:35 編輯
回復 1# h60327
For i = [K1] To [K1] + 730 超過一年會造成資料不正確
建議 : 假日,平日 週日 要修改為 For i = [K1] To DateAdd("yyyy", 1, [k1]) - 1 且K1 是要同一天
總表B2:-> 2011/09 XXXX 中間要空一格- 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
|
|
發表於 2011-9-10 12:52
| 
