- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 114
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-5-17
              
|
回復 6# totes - Sub nn()
- Dim A As Range
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- Set d2 = CreateObject("Scripting.Dictionary")
- Set d3 = CreateObject("Scripting.Dictionary")
- s = Sheet3.[E1]: n = Sheet3.[G1]
- With Sheet2
- For Each A In Range(.[A2], .[A65536].End(xlUp))
- If A >= s And A <= n And A <> "" Then '在區間內
- dy = DateValue(Format(A, "yyyy/m/d"))
- t = TimeValue("07:00:00")
- If TimeValue(Format(A, "hh:mm:ss")) < t Then dy = dy - 1
- d3(dy) = ""
- mystr = dy & A.Offset(, 1)
- d1(mystr) = d1(mystr) + 1
- If IsEmpty(d(mystr)) Then
- ar = Array(0, 0, 0, 0, 0, 0, 0)
- ay = Array(4, 3, 2, 1, 5, 6, 7)
- k = Val(A.Offset(, 5))
- If k <> 0 Then ar(ay(k - 1) - 1) = ar(ay(k - 1) - 1) + 1
- d(mystr) = ar
- ng = Application.Sum(ar)
- ary = Array(dy, ng, ar(3), ar(2), ar(1), ar(0), ar(4), ar(5), ar(6), d1(mystr), ng / d1(mystr))
- d2(mystr) = ary
- Else
- ar = d(mystr)
- k = Val(A.Offset(, 5))
- If k <> 0 Then ar(ay(k - 1) - 1) = ar(ay(k - 1) - 1) + 1
- d(mystr) = ar
- ng = Application.Sum(ar)
- ary = Array(dy, ng, ar(0), ar(1), ar(2), ar(3), ar(4), ar(5), ar(6), d1(mystr), ng / d1(mystr))
- d2(mystr) = ary
- End If
- End If
- Next
- End With
- ak = Array("DASM20", "DASM40")
- With Sheet4
- For i = 0 To 1
- r = 3
- For Each ky In d3.keys
- If Not IsEmpty(d2(ky & ak(i))) Then
- .Cells(r, i * 10 + i + 1).Resize(, 11) = d2(ky & ak(i))
- If i = 1 Then .Cells(r, 23) = .Cells(r, 19) / .Cells(r, 21)
- Else
- .Cells(r, i * 10 + i + 1).Resize(, 11) = Array(ky, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
- If i = 1 Then .Cells(r, 23) = 0
- End If
- r = r + 1
- Next
- Next
- End With
- End Sub
|
|
發表於 2011-4-13 22:30
| 
