准提部林

Sub TEST()
Dim i&, R&, C&, xD, xArea As Range, Arr, xR As Range, X&, Y&, Z%
C = [IV2].End(xlToLeft).Column
R = [B65536].End(xlUp).Row
Set xD = CreateObject("Scripting.Dictionary")
For i = 4 To R Step 4:  xD(Cells(i, 1) & "") = i - 3: Next i　　'取得〔Tester No〕的〔列位〕
For i = 3 To C:  xD(Format(Cells(2, i), "yyyy-mm-dd")) = i - 2: Next i　'取得日期的〔欄位〕
Set xArea = [C4].Resize(R - 3, C - 2)　'統計數值區
xArea.ClearContents: Arr = xArea　'清除統計，以Arr代出
　
For Each xR In Range([summary!D3], [summary!D65536].End(xlUp))
　　X = xD(xR.Value)　'〔Tester No〕的〔列位〕
　　Y = xD(Format(xR(1, 3), "yyyy-mm-dd"))　'日期的〔欄位〕
　　If X = 0 Or Y = 0 Then GoTo 101
　　Z = Int(Hour(xR(1, 3)) / 8)　'早午晚時段計算
　　Arr(X + Z, Y) = Arr(X + Z, Y) + 1　'累計時段次數
　　Arr(X + 3, Y) = Arr(X + 3, Y) + 1　'累計當日次數
101: Next
xArea = Arr
End Sub

yen956

請自行測試看看!!(資料太多)

1. Private Sub CommandButton1_Click()
   
2.    Dim LastR As Integer, I As Integer
   
3.    Dim Rng As Range, fAddr As String
   
4.    Dim Col1 As Integer, Off1 As Integer, H1 As Integer
   
5.    LastR = [D65536].End(xlUp).Row
   
6.    [F2:AI73] = ""
   
7.    For I = 2 To LastR Step 4
   
8.        Set Rng = [A:A].Find(Cells(I, 4), Lookat:=xlWhole)  '欄A 中尋找TesterNo
   
9.        If Not Rng Is Nothing Then
   
10.            fAddr = Rng.Address
    
11.            Do
    
12.                Col1 = Day(Rng.Offset(0, 1)) + 5
    
13.                H1 = Hour(Rng.Offset(0, 1))
    
14.                Off1 = IIf(H1 < 16, 1, 2)
    
15.                If H1 < 8 Then Off1 = 0
    
16.                Cells(I + Off1, Col1) = Cells(I + Off1, Col1) + 1
    
17.                Cells(I + 3, Col1) = Cells(I + 3, Col1) + 1
    
18.                Set Rng = [A:A].FindNext(Rng)   '尋找下一個TesterNo
    
19.            Loop Until fAddr = Rng.Address      '直到下一個TesterNo的位置=第一個TesterNo的位置
    
20.        End If
    
21.    Next
    
22. End Sub

複製代碼

下載 (56.85 KB)

2015-11-29 17:54

jeff5424

回復 9# hcm19522
感謝hcm19522大大的幫忙,我在測試正常.....謝謝

jeff5424

回復 12# yen956
yen956 大大,我測試後不能用巨集/VBA,可以麻煩大大給我原始檔嗎....謝謝

yen956

回復 14# jeff5424
可能是巨集安全性的問題,
將巨集安全性調低就可以了.

下載 (162.47 KB)

2015-11-30 08:11

jeff5424

回復 15# yen956
yen956 大大,我測試出現err(如圖所示),可以將excel檔嗎....謝謝

yen956

回復 16# jeff5424
舊VBA Code沒刪乾淨!!
將第一列刪除即可.

http://www.mediafire.com/download/8t334h19m3lr82m/%E7%B4%AF%E8%A8%88%E6%AC%A1%E6%95%B8.rar

jeff5424

回復 17# yen956
感謝yen956大大....測試OK.....謝謝