- 帖子
- 2843
- 主題
- 10
- 精華
- 0
- 積分
- 2899
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2025-10-18
|
12#
發表於 2020-3-27 11:46
| 只看該作者
回復 11# gaishutsusuru
若各類匯總結果固定最多6000筆, 可稍簡化:- Sub TEST()
- Dim Arr, Brr, xD, r&, c%, i&, j&, k%, N&(2), Sr As Range
- [O2:AP6000].Clear: Brr = [O2:AP6000]
- Set xD = CreateObject("Scripting.Dictionary")
- For Each Sr In [L2:M30]
- k = 1 - k: If Sr <> "" Then xD(Sr & "/") = 2 - k
- Next
- '--------------------------------
- Arr = Range([J1], Cells(Rows.Count, 1).End(xlUp))
- For i = 2 To UBound(Arr)
- If IsDate(Arr(i, 3)) * IsDate(Arr(i, 3)) = 0 Then GoTo 101
- c = xD(Arr(i, 2) & "/")
- For j = Arr(i, 3) To Arr(i, 4) - 1
- r = xD(j & "|" & c)
- If r = 0 Then N(c) = N(c) + 1: r = N(c): xD(j & "|" & c) = r
- Brr(r, c * 10 + 2) = CDate(j)
- For k = 3 To 8: Brr(r, c * 10 + k) = Brr(r, c * 10 + k) + Arr(i, k + 2): Next k
- Next j
- 101: Next i
- '''--------------------------------
- [O2:AP6000] = Brr
- For Each Sr In Range("P2,Z2,AJ2")
- Sr.Resize(6000, 7).Sort Key1:=Sr, Order1:=xlAscending, Header:=xlNo
- Next
- MsgBox "~~分類加總完成~~ "
- End Sub
|
|
發表於 2020-3-26 17:26
| 
