[attach]34494[/attach]

C 欄輸入張數...面額100 編號由 A0064565起算
D欄能自動產生所需張數編號  A0064565~A0066053

D欄能自動產生所需張數編號  B0081141~B0084118

[attach]34495[/attach]

Sub test()
Dim Arr, xD, Brr, T, T1, TT\$, ck%, ck1%, i&
Set xD = CreateObject("Scripting.Dictionary")
With Range([D2], [B65536].End(3))
Brr = .Value
.Sort Key1:=.Item(1), Order1:=1, Header:=1
Arr = .Value
For i = 2 To UBound(Arr)
TT = Arr(i, 1) & "|" & Arr(i, 2)
If Arr(i, 1) = 100 Then
If ck = 0 Then
T = 64565
Arr(i, 3) = "A00" & T & "-" & Format(T + Arr(i, 2) - 1, "A0000000")
ck = 1: T1 = T + Arr(i, 2): xD(TT) = Arr(i, 3)
Else
Arr(i, 3) = "A00" & T1 & "-" & Format(T1 + Arr(i, 2) - 1, "A0000000")
T1 = T1 + Arr(i, 2): xD(TT) = Arr(i, 3)
End If
ElseIf Arr(i, 1) = 500 Then
If ck1 = 0 Then
T = 81141
Arr(i, 3) = "B00" & T & "-" & Format(T + Arr(i, 2) - 1, "B0000000")
ck1 = 1: T1 = T + Arr(i, 2): xD(TT) = Arr(i, 3)
Else
Arr(i, 3) = "B00" & T1 & "-" & Format(T1 + Arr(i, 2) - 1, "B0000000")
T1 = T1 + Arr(i, 2): xD(TT) = Arr(i, 3)
End If
End If
Next
For i = 2 To UBound(Brr): TT = Brr(i, 1) & "|" & Brr(i, 2): Brr(i, 3) = xD(TT): Next
.Value = Brr
End With
End Sub

[attach]34496[/attach]

1. Function zz(面額, 張數)
2. Dim rng As Range, n&, r&, c&, b, x, i&
3. r = 張數.Row
4. c = 張數.Column
5. b = Cells(1, c + 1).Resize(r - 1)
6. Select Case 面額
7.     Case 100: x = "A"
8.     Case 500: x = "B"
9. End Select
10. For i = 1 To UBound(b)
11.     If Left(b(i, 1), 1) = x Then n = i
12. Next
13. If n Then i = Mid(b(n, 1), Application.Find(x, b(n, 1), 2) + 1) Else i = 0
14. zz = x & Format(i + 1, "0000000") & "-" & x & Format(i + 張數, "0000000")
15. End Function

https://blog.xuite.net/hcm19522/twblog/590165834

[attach]34500[/attach]

>> 修改如下紅字，請測試看看，謝謝

Sub test()
Dim Arr, xD, Brr, T, T1, TT\$, ck%, ck1%, i&
Set xD = CreateObject("Scripting.Dictionary")
With Range([D2], [B65536].End(3))
Brr = .Value
.Sort Key1:=.Item(1), Order1:=1, Header:=1
Arr = .Value
For i = 2 To UBound(Arr)
TT = Arr(i, 1) & "|" & Arr(i, 2)
If Arr(i, 1) = 100 Then
If ck = 0 Then
T = 64565
Arr(i, 3) = "A00" & T & "-" & Format(T + Arr(i, 2) - 1, "A0000000")
ck = 1: T1 = T + Arr(i, 2): xD(TT) = Arr(i, 3)
Else
Arr(i, 3) = "A00" & T1 & "-" & Format(T1 + Arr(i, 2) - 1, "A0000000")
T1 = T1 + Arr(i, 2): xD(TT) = Arr(i, 3)
End If
ElseIf Arr(i, 1) = 200 Then
If ck1 = 0 Then
T = 81141
Arr(i, 3) = "B00" & T & "-" & Format(T + Arr(i, 2) - 1, "B0000000")
ck1 = 1: T1 = T + Arr(i, 2): xD(TT) = Arr(i, 3)
Else
Arr(i, 3) = "B00" & T1 & "-" & Format(T1 + Arr(i, 2) - 1, "B0000000")
T1 = T1 + Arr(i, 2): xD(TT) = Arr(i, 3)
End If
End If
Next
For i = 2 To UBound(Brr): TT = Brr(i, 1) & "|" & Brr(i, 2): Brr(i, 3) = xD(TT): Next
.Value = Brr
End With
End Sub

化碼基本上是追蹤對上一次的號碼，在没有的情調下從1開始，若一定在没有對上一次的號碼，要用指定的號碼，可以在 13 行 else 後面的 i 做修改。

If n Then i = Mid(b(n, 1), Application.Find(x, b(n, 1), 2) + 1) Else i = 64564

[attach]34503[/attach]

>>請測試看看，謝謝
Sub test()
Dim Arr, xD, Brr, T, T1, TT\$, ck%, ck1%, i&
Set xD = CreateObject("Scripting.Dictionary")
With Range([D2], [B65536].End(3)-2)
Brr = .Value
.Sort Key1:=.Item(1), Order1:=1, Header:=1
...
...

=REPLACE(TEXT(MMULT((IF(B3=100,64564,81140)+SUMIF(B\$2:B2,B3,C\$2:C2)+C3^{0,1}),10^{7;0}),REPT(IF(B3=100,"A","B")&"0000000",2)),9,,"-")

[attach]34510[/attach]

[attach]34511[/attach]

[attach]34512[/attach]

[attach]34513[/attach]

[attach]34514[/attach]

>> 請再測試看看，謝謝
Sub test()
Dim Arr, xD, Brr, T, T1, TT\$, ck%, ck1%, i&
Set xD = CreateObject("Scripting.Dictionary")
With Range("b2:d" & [B65536].End(3).Row - 2)
Brr = .Value
.Sort Key1:=.Item(1), Order1:=1, Header:=1
Arr = .Value
For i = 2 To UBound(Arr)
TT = Arr(i, 1) & "|" & Arr(i, 2)
If Arr(i, 1) = 100 Then
If ck = 0 Then
T = 64565
Arr(i, 3) = "A00" & T & "-" & Format(T + Arr(i, 2) - 1, "A0000000")
ck = 1: T1 = T + Arr(i, 2): xD(TT) = Arr(i, 3)
Else
Arr(i, 3) = "A00" & T1 & "-" & Format(T1 + Arr(i, 2) - 1, "A0000000")
T1 = T1 + Arr(i, 2): xD(TT) = Arr(i, 3)
End If
Else
If ck1 = 0 Then
T = 81141
Arr(i, 3) = "B00" & T & "-" & Format(T + Arr(i, 2) - 1, "B0000000")
ck1 = 1: T1 = T + Arr(i, 2): xD(TT) = Arr(i, 3)
Else
Arr(i, 3) = "B00" & T1 & "-" & Format(T1 + Arr(i, 2) - 1, "B0000000")
T1 = T1 + Arr(i, 2): xD(TT) = Arr(i, 3)
End If
End If
Next
For i = 2 To UBound(Brr): TT = Brr(i, 1) & "|" & Brr(i, 2): Brr(i, 3) = xD(TT): Next
.Value = Brr
End With
End Sub

18#除了更新列數問題，因為你的B欄除了500元有時又會有200元問題(代碼都是共用B開頭)，也有更新此問題，謝謝

2000版做的, 公式及vba各一:
[attach]34515[/attach]

Sub 流水編號()
Dim Arr, i&, P%, V&, N&, T1\$, T2\$, x%, TR, YR, SS&(3)
Arr = Range([c1], [b65536].End(xlUp)(1, 0))
TR = [{"A","F","B"}]
YR = [{64564,38000, 81140}]
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, 3, P = P, 0)
If P = 0 Or V = 0 Or x = 0 Then GoTo i01
T1 = TR(x) & Format(YR(x) + SS(x) + 1, "0000000")
T2 = TR(x) & Format(YR(x) + 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

[attach]34516[/attach]

[attach]34517[/attach]
TR = [{"A","F","B"}]
YR = [{64564,38000, 81140}]

x = Switch(P = 100, 1, P = 200, 2, P = 500, 3, P = P, 0)

[attach]34521[/attach]

[attach]34523[/attach]

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

[attach]34525[/attach]

[attach]34526[/attach]

 歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)