missbb

回復 10# lpk187


    太感謝了, 我會學習當中運用, 有勞大司:'( 為我解決了頭痛多月的問題!

lpk187

回復 11# missbb

我發現，可能你當初寫這檔案時曾產生溢位而導致檔案變很大，來到1.7M
已經幫你處理好了(不過畫面有點不像原來的樣子)，另外新增加一些功能”清除資料“ 及 ”自動填寫日期“以及程式解說，以利你明瞭程式的動作
   
考勤表 20150815 v5.rar (44.95 KB)

下載次數: 20

2015-8-16 12:10

missbb

回復 12# lpk187

是呀, 用函數令FILE運作很慢才用VBA, 感謝細心的增值:'(

GBKEE

回復 13# missbb
字典物件,也可試試看.

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim xDATE As Range, i, Rng As Range
   
4.     Dim D As Object, K, X As Long, Ar As Variant
   
5.     Set xDATE = Sheets("Attendance Report").[J3]  '輸入報表首日之前1日日期 的儲存格
   
6.     With Sheets("data")  '資料工作表
   
7.         Set Rng = .[D4] '資料開使的儲存格
   
8.         X = 0
   
9.         Do While Rng <> ""
   
10.             Set D = CreateObject("SCRIPTING.DICTIONARY")  '設立變數 :字典物件
    
11.             i = 1
    
12.             Do While Rng.Offset(i - 1) = Rng  'Employee  上下列相同
    
13.                 With Rng.Offset(i - 1)
    
14.                     If D.EXISTS(.Range("C1").Value) Then    '如果在 Dictionary 物件中指定的關鍵字存在，傳回 True，
    
15.                         D(.Range("C1").Value) = D(.Range("C1").Value) & "," & .Range("D1").Text
    
16.                     Else
    
17.                         D(.Range("C1").Value) = .Range("D1").Text
    
18.                         '.Range("C1").Value 為日期值
    
19.                     End If
    
20.                  End With
    
21.                 i = i + 1
    
22.             Loop
    
23.             For Each K In D.KEYS  'Keys 方法 傳回一個陣列，該陣列包含一個 Dictionary 物件中的全部既存的的關鍵字。
    
24.                 Ar = Split(D(K), ",") 'Keys的內容
    
25.                 With xDATE.Offset(, K - xDATE)  'k 為日期值
    
26.                     .Parent.Cells(.Row + X + 1, "a") = Rng.Range("b1").Value
    
27.                     .Parent.Cells(.Row + X + 1, "d").Resize(20) = Rng
    
28.                     If UBound(Ar) = 1 Then
    
29.                         .Cells(X + 3) = Ar(0)
    
30.                         .Cells(X + 4) = Ar(1)
    
31.                     ElseIf UBound(Ar) = 2 Then
    
32.                         .Cells(X + 3) = Ar(0)
    
33.                         .Cells(X + 4) = Ar(2)
    
34.                         .Cells(X + 10) = Ar(1)
    
35.                     ElseIf UBound(Ar) = 3 Then
    
36.                         .Cells(X + 3) = Ar(0)
    
37.                         .Cells(X + 4) = Ar(3)
    
38.                         .Cells(X + 10) = Ar(1)
    
39.                         .Cells(X + 11) = Ar(2)
    
40.                     ElseIf UBound(Ar) = 4 Then
    
41.                         .Cells(X + 3) = Ar(0)
    
42.                         .Cells(X + 4) = Ar(4)
    
43.                         .Cells(X + 10) = Ar(1)
    
44.                         .Cells(X + 11) = Ar(2)
    
45.                     End If
    
46.                 End With
    
47.             Next
    
48.             X = X + 20
    
49.             Set Rng = Rng.Offset(i)
    
50.         Loop
    
51.     End With
    
52. End Sub

複製代碼

missbb

回復 14# GBKEE
想請教將("A4:AP23") COPY 等如員工人數的次數, 但出錯, 是甚麼原因?

1. [code]Sub COPY_FORMAT()
   
2. 
   
3. Dim i As Integer
   
4. 
   
5.     Worksheets("attendance report").Activate
   
6.    
   
7.     QQQQ = Worksheets("ee data").Cells(Rows.Count, "b").End(xlUp).Row
   
8.    
   
9.     ActiveSheet.Range("A4:AP23").Select
   
10.    
    
11.     Selection.Copy
    
12.    
    
13. For i = 1 To QQQQ
    
14.    
    
15.     ActiveSheet.Range("A" & 1 + i * 20).Select
    
16.     ActiveSheet.Paste
    
17.   
    
18. Next i
    
19. End Sub
    
20. 
    
21.         
    
22. 
    
23. 
    
24.    

複製代碼

[/code]

lpk187

回復 15# missbb

ActiveSheet.Range("A4:AP23").Select
   
    Selection.Copy次<<這裡裡是選擇上面範圍A4:AP23製範圍的複製
但下面的紅色部份卻把上面的選擇更換掉了，所以它只能貼一次，第二次就會出錯了！
For i = 1 To QQQQ
     ActiveSheet.Range("A" & 1 + i * 20).Select
    ActiveSheet.Paste
  Next i
要複製貼上，只要一句就可解決，如下範例：

1. Sub COPY_FORMAT()
   
2. Dim i As Integer
   
3.     Worksheets("attendance report").Activate
   
4.     QQQQ = Worksheets("ee data").Cells(Rows.Count, "b").End(xlUp).Row
   
5. For i = 1 To QQQQ
   
6.     ActiveSheet.Range("A4:AP23").Copy Range("A" & 1 + i * 20)
   
7. Next i
   
8. End Sub

複製代碼

missbb

回復 16# lpk187
多謝指導.

missbb

回復 14# GBKEE

想問為何可以取得姓名呢?因為我在EE DATA及EE內都找不到對應的欄?

           .Parent.Cells(.Row + X + 1, "d").Resize(20) = Rng

另可否從EE DATA一版內將員工編號及部門都放在ATTENDANCE內並顯示20列呢?

有勞賜教!

GBKEE

回復 18# missbb

你附檔的ee data 員工只有2位,可多舉一些.看看

missbb

回復 16# lpk187


        感謝賜教!