- 帖子
- 2839
- 主題
- 10
- 精華
- 0
- 積分
- 2895
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-12-18
|
19#
發表於 2021-12-4 13:26
| 只看該作者
回復 18# shuo1125
Sub TEST_A4()
Dim Arr, Brr, Cr, xD, vD, i&, j%, R&, K, T1$, T2$, TT$, N&, V%, xA As Range
tm = Timer
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
Set vD = CreateObject("Scripting.Dictionary")
Arr = Range([DATA!at1], [DATA!a65536].End(xlUp))
For i = 2 To UBound(Arr)
If Arr(i, 46) <> "" Then GoTo i01
T1 = Arr(i, 11): T2 = Arr(i, 6): TT = T1 & T2
If T1 = "" Or T2 = "" Or xD(TT) > 0 Then GoTo i01
If xD(T1) = 0 Then Set vD(T1) = CreateObject("Scripting.Dictionary")
xD(T1) = 1: xD(TT) = 1: vD(T1)(i) = ""
i01: Next i
'--------------------------------
Application.ScreenUpdating = False
Set xA = [盤點表!A1]: Cr = Array(1, 3, 6, 8, 10, 14, 13, 12)
For Each K In vD.keys
R = vD(K).Count: N = N + 1
ReDim Brr(1 To R + 1, 1 To 10)
For i = 1 To R
V = vD(K).keys()(i - 1)
Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
For j = 1 To 8: Brr(i, j) = Arr(V, Cr(j - 1)): Next
Next i
[盤點表!A1:j3].Copy xA
xA(2, 2) = K: xA(2, 10) = "頁次：" & N & "/" & vD.Count
[盤點表!a4:j4].Copy xA(4).Resize(R, 10)
xA(4).Resize(R + 1, 10).Value = Brr
Set xA = xA(R + 5): xA.PageBreak = xlPageBreakManual '設定分頁線
Next
MsgBox Timer - tm
End Sub |
|
發表於 2021-11-25 10:24
| 
