- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-5-5
|
40#
發表於 2023-11-15 16:41
| 只看該作者
回復 39# cypd
謝謝論壇,謝謝前輩指導
後學藉此帖練習修改新方案,學習到很多知識,請前輩再指導
 20231115+_20231115.zip (15.48 KB)
執行前:
執行3次:
Option Explicit
Sub TEST_1()
Dim Brr, Z, C, A(2), P1&, P2&, Q%, i&, j%, V&, F$, T$, Ts$, Te$, R&, U%
Set Z = CreateObject("Scripting.Dictionary")
U = [IV2].End(xlToLeft).Column: Brr = Range(Cells(2, U), [H65536].End(3)(1, 2))
For j = 1 To UBound(Brr, 2): Z(Val(Brr(1, j))) = Val(Brr(UBound(Brr), j)): Next
For j = 0 To UBound(Z.KEYS()): Z(Z.KEYS()(j) & "") = Brr(2, j + 1): Next
R = UBound(Brr): C = Application.Match("合計", [A:A], 0)
If IsError(C) Then Exit Sub Else F = Application.Rept("0", 7)
Brr = [B3].Resize(C - 3, 3)
For i = 1 To UBound(Brr)
P1 = Val(Brr(i, 1)): P2 = Val(Brr(i, 2)): Brr(i, 1) = ""
If P1 * P2 = 0 Then GoTo i01
V = Z(P1): T = Z(P1 & ""): If V = 0 Then GoTo i01
Ts = T & Format((V + 1), F)
V = V + Brr(i, 2): Z(P1) = V
Te = T & Format((V), F)
Brr(i, 1) = Ts & "-" & Te
i01: Next
[D3].Resize(UBound(Brr)) = Brr
Cells(R + 2, "I").Resize(1, U - 8) = Z.ITEMS: Cells(R + 2, "I").Item(1, 0) = Now
End Sub |
|
