版主加強了以下公式
Sub 流水編號1()
Dim Arr, i&, P%, V&, N&, T1$, T2$, TT$, x%, Y&, SS(2)
Arr = Range([c1], [b65536].End(xlUp)(1, 0))
For i = 3 To UBound(Arr)
If Arr(i, 1) = "合計" Then Exit For
N = N + 1: Arr(i - 2, 1) = ""
P = Val(Arr(i, 2)): V = Val(Arr(i, 3))
x = Switch(P = 100, 1, P = 200, 2, P = 500, 2, P = P, 0)
If P = 0 Or V = 0 Or x = 0 Then GoTo i01
Y = Array(64564, 81140)(x - 1): TT = Array("A", "B")(x - 1)
T1 = TT & Format(Y + SS(x) + 1, "0000000")
T2 = TT & Format(Y + SS(x) + V, "0000000")
Arr(i - 2, 1) = T1 & IIf(T1 = T2, "", "-" & T2)
SS(x) = SS(x) + V
i01: Next i
[d3].Resize(N) = Arr
End Sub
Option Explicit
Sub TEST_1()
Dim Brr, Z, C, A(2), P%, Q%, i%, V%, F$, T$, Ts$, Te$
Set Z = CreateObject("Scripting.Dictionary")
C = Application.Match("合計", [A:A], 0)
If IsError(C) Then Exit Sub Else F = "0000000"
Brr = [B3].Resize(C - 3, 3)
A(0) = [{1,2,5,10}]
A(1) = [{124,99,84,54}]
A(2) = [{"A","B","C","D"}]
For i = 1 To UBound(A(0)):
Q = A(0)(i) * 100: Z(Q) = A(1)(i): Z(Q & "") = A(2)(i)
Next
For i = 1 To UBound(Brr)
P = Brr(i, 1): V = Z(P): T = Z(P & "")
Ts = T & Format((V + 1), F)
V = V + Brr(i, 2): Z(P) = V
Te = T & Format((V), F)
Brr(i, 1) = Ts & "-" & Te
Next
[D3].Resize(UBound(Brr)) = Brr
End Sub作者: cypd 時間: 2023-11-15 14:21
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作者: cypd 時間: 2023-11-15 22:36
