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 時間: 2015-11-29 17:54
請自行測試看看!!(資料太多)
Private Sub CommandButton1_Click()
Dim LastR As Integer, I As Integer
Dim Rng As Range, fAddr As String
Dim Col1 As Integer, Off1 As Integer, H1 As Integer
LastR = [D65536].End(xlUp).Row
[F2:AI73] = ""
For I = 2 To LastR Step 4
Set Rng = [A:A].Find(Cells(I, 4), Lookat:=xlWhole) '欄A 中尋找TesterNo
If Not Rng Is Nothing Then
fAddr = Rng.Address
Do
Col1 = Day(Rng.Offset(0, 1)) + 5
H1 = Hour(Rng.Offset(0, 1))
Off1 = IIf(H1 < 16, 1, 2)
If H1 < 8 Then Off1 = 0
Cells(I + Off1, Col1) = Cells(I + Off1, Col1) + 1
Cells(I + 3, Col1) = Cells(I + 3, Col1) + 1
Set Rng = [A:A].FindNext(Rng) '尋找下一個TesterNo
Loop Until fAddr = Rng.Address '直到下一個TesterNo的位置=第一個TesterNo的位置
感謝hcm19522大大的幫忙.....謝謝