[發問] 將不同工作值匯在一個工作表內

h60327

123.rar (28.12 KB)

下載次數: 24

2011-9-10 12:52

各位先進這是一個值班統計表，平日係由A組人輪值，週六及其他例假日仍由A組人員輪值，星期日由B組人輪值，請問要如何將三個工作表的輪值狀況會整在一個工作表內呢，用函數是否可以達成

GBKEE

回復 1# h60327
For i = [K1] To [K1] + 730     超過一年會造成資料不正確     
建議 : 假日,平日 週日 要修改為 For i = [K1] To DateAdd("yyyy", 1, [k1]) - 1     且K1 是要同一天

總表B2:->  2011/09 XXXX    中間要空一格

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

複製代碼

Hsieh

回復 1# h60327

函數完成請見附件
123.rar (22.41 KB)

下載次數: 24

2011-9-10 23:53

oobird

樞鈕也很方便呀。

下載 (92.37 KB)

2011-9-11 00:26

h60327

由於權限還無法下載，請問Hsieh板大函數公式為何呢？再次感謝各位先進的指教