- 帖子
- 2842
- 主題
- 10
- 精華
- 0
- 積分
- 2898
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2025-4-28
|
9#
發表於 2017-3-25 10:52
| 只看該作者
回復 6# oak0723-1
- Sub TEST()
- Dim i&, R&, C&, Arr, Brr, xD, V, U
- Call Clear_All
- Arr = Range("A8:D" & Cells(Rows.Count, 1).End(xlUp).Row)
- Set xD = CreateObject("Scripting.Dictionary")
- For i = 1 To UBound(Arr): xD(Arr(i, 2)) = "": Next i
- U = xD.Count
- For i = 1 To U
- V = Application.Large(xD.keys, i)
- xD(V) = i * 8 - 7: [i6].Cells(1, xD(V)) = V
- Next i
- R = Cells(Rows.Count, "H").End(xlUp).Row - 10
- If R <= 0 Then Exit Sub
- Brr = [H11].Resize(R)
- For i = 1 To R: xD(Brr(i, 1)) = i: Next i
- ReDim Brr(1 To R, 1 To U * 8)
- For i = 1 To UBound(Arr)
- R = xD(Arr(i, 1)): C = xD(Arr(i, 2)): If R = 0 Or C = 0 Then GoTo 101
- V = Arr(i, 3)
- If V >= [I9] And V < [K9] Then Brr(R, C + 0) = Brr(R, C + 0) + V: Brr(R, C + 1) = Brr(R, C + 1) + 1
- If V >= [M9] And V < [O9] Then Brr(R, C + 4) = Brr(R, C + 4) + V: Brr(R, C + 5) = Brr(R, C + 5) + 1
- V = Arr(i, 4)
- If V >= [I9] And V < [K9] Then Brr(R, C + 2) = Brr(R, C + 2) + V: Brr(R, C + 3) = Brr(R, C + 3) + 1
- If V >= [M9] And V < [O9] Then Brr(R, C + 6) = Brr(R, C + 6) + V: Brr(R, C + 7) = Brr(R, C + 7) + 1
- 101: Next i
- [i11].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
- End Sub
 060318-流水帳&分類帳_v1.rar (15.54 KB)
|
|
發表於 2017-3-19 17:38
| 
感恩
