Board logo

標題: [發問] VBA計算箱子號碼 [打印本頁]
作者: john2006168    時間: 2021-4-22 11:56     標題: VBA計算箱子號碼

本帖最後由 john2006168 於 2021-4-22 11:59 編輯

請問有沒有老師可以幫忙寫一下,學習一下不同的思路?
想要黃色的結果
revised plt4
PLT NO.        4        40        C1-C40        C
作者: samwang    時間: 2021-4-22 13:12

回復 1# john2006168


不好意思，看不太懂解規則是什麼，可否請再細說明一下，謝謝
作者: john2006168    時間: 2021-4-22 13:59

回復 2# samwang
考慮條件E欄是順序P和C的,如果是P板,第一板是10件,編紙箱號碼就用P1-P10,第二板20件,就用P11-P30,以此類推.,如果是C板,第一板是10件,編紙箱號碼就用C1-C10,第二板20件,就用C11-C30,以此類推.
作者: samwang    時間: 2021-4-22 15:20

回復 3# john2006168

請測試看看，謝謝。

Sub test()
Dim Arr, xD, TT, T, T1, T2, T3, N%, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = [A1].CurrentRegion
For i = 2 To UBound(Arr)
    T = Arr(i, 5): T2 = Arr(i, 2): T3 = Arr(i, 3)
    If xD.Exists(T & "") Then
        If N = 0 Then
            N = 1: TT = xD(T & "")(0)
        Else
            TT = xD(T & "")(0) + T1
        End If
        Arr(i, 1) = Arr(i, 5) & TT & "1" & "-" & T & T3 + xD(T & "")(1)
        xD(T & "") = Array(T2, T3 + xD(T & "")(1))
    Else
        Arr(i, 1) = Arr(i, 5) & "1" & "-" & T & T3
        xD(T & "") = Array(T2, T3): N = 0: T1 = xD(T & "")(0)
    End If
Next
Arr(1, 1) = "Carton"
Range("D1").Resize(UBound(Arr), 1) = Arr
End Sub
作者: john2006168    時間: 2021-4-22 15:52

回復 4# samwang

謝謝老師.這個可以,感謝抽時間回覆,但是看得不是很懂.如果有注解會更好點.
另外,請問有沒有其他大大,可以提供其他寫法(不用UBound 函數)
作者: samwang    時間: 2021-4-22 17:20

回復 5# john2006168

我盡力加入註解，可能有些寫得不好不詳細，請您自行研究了，謝謝。

Sub test1()
Dim Arr, xD, TT, T, T1, T2, T3, N%, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = [A1].CurrentRegion   '資料放入數組
For i = 2 To UBound(Arr)
    'T:E欄資料、T2:B欄、T3:C欄
    T = Arr(i, 5): T2 = Arr(i, 2): T3 = Arr(i, 3)
    If xD.Exists(T & "") Then '字典有無E欄資料
        If N = 0 Then
            N = 1: TT = xD(T & "")(0) '重複出現的第1次依規則編號(第2碼)
        Else
            TT = xD(T & "")(0) + T1 '重複出現的第2次以上依規則編號(第2碼)
        End If
        Arr(i, 1) = Arr(i, 5) & TT & "1" & "-" & T & T3 + xD(T & "")(1) '依規則編號
        xD(T & "") = Array(T2, T3 + xD(T & "")(1)) 'C欄(kg)累加裝入字典
    Else
        Arr(i, 1) = Arr(i, 5) & "1" & "-" & T & T3  '第1次出現，依規則編號放入Arr
        xD(T & "") = Array(T2, T3): N = 0: T1 = xD(T & "")(0) 'B,C欄資料放入字典，T1設為B欄第一次出現數值，N=0歸零(P-C)
    End If
Next
Arr(1, 1) = "Carton"
Range("d1").Resize(UBound(Arr), 1) = Arr
End Sub
作者: john2006168    時間: 2021-4-22 17:35

回復 6# samwang


   不好意思,如果加資料去到第5行,數字不對.應該是P61-P90
作者: samwang    時間: 2021-4-22 17:48

回復 7# john2006168


請問PXX - 的規則如何??
作者: john2006168    時間: 2021-4-22 18:00

回復 8# samwang

是件數,要累加.
作者: john2006168    時間: 2021-4-22 18:48

回復 9# john2006168

我再將excel給您看一下
作者: samwang    時間: 2021-4-22 19:52

回復 10# john2006168

請再測試看看，感謝。

Sub test2()
Dim Arr, xD, TT, T, T2, T3, N%, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = [A1].CurrentRegion   '資料放入數組
For i = 2 To UBound(Arr)
    'T:E欄資料、T2:B欄、T3:C欄
    T = Arr(i, 5): T2 = Arr(i, 2): T3 = Arr(i, 3)
    If xD.Exists(T & "") Then '字典有無E欄資料
        If N = 0 Then
            N = 1: TT = Arr(i - 1, 3) + 1 '重複出現的第1次依規則編號(第2碼)
        Else
            TT = xD(T & "")(1) + 1  '重複出現的第2次以上依規則編號(第2碼)
        End If
        Arr(i, 1) = Arr(i, 5) & TT & "-" & T & T3 + xD(T & "")(1)  '依規則編號
        xD(T & "") = Array(T2, T3 + xD(T & "")(1)) 'C欄(kg)累加裝入字典
    Else
        Arr(i, 1) = Arr(i, 5) & "1" & "-" & T & T3  '第1次出現，依規則編號放入Arr
        xD(T & "") = Array(T2, T3): N = 0  'B,C欄資料放入字典，N=0歸零(P-C)
    End If
Next
Arr(1, 1) = "Carton"
Range("D1").Resize(UBound(Arr), 1) = Arr
End Sub
作者: jcchiang    時間: 2021-4-22 23:00

回復 10# john2006168
試試看
Sub ex()
Dim d As Object, a As Variant
Set d = CreateObject("Scripting.dictionary")
For Each a In Range([E2], [E65535].End(3))   '在E欄位置找尋資料
   If Not d.exists(a.Value) Then   '字典中找不到資料
      d(a.Value) = a.Offset(, -2)  '將資料存入字典
      a.Offset(, -1) = a.Value & "1-" & a.Value & a.Offset(, -2) '將範圍資料填入儲存格
   Else   '字典中找到資料
      a.Offset(, -1) = a.Value & d(a.Value) + 1 & "-" & a.Value & a.Offset(, -2) + d(a.Value) '將範圍資料填入儲存格
      d(a.Value) = a.Offset(, -2) + d(a.Value)   '更新字典資料
   End If
Next
Set d = Nothing
End Sub
作者: john2006168    時間: 2021-4-23 09:04

回復 11# samwang

謝謝您再三回覆,程式可以操作.
作者: john2006168    時間: 2021-4-23 09:06

回復 12# jcchiang

謝謝回覆,可以學習不同寫法.
作者: samwang    時間: 2021-4-23 09:22

上次寫得不好，簡化一下如下，謝謝。

Sub test3()
Dim Arr, xD, T, T2, T3, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([A1], [E65536].End(3))  '資料放入數組
For i = 2 To UBound(Arr)
    'T:E欄資料、T2:B欄、T3:C欄
    T = Arr(i, 5): T2 = Arr(i, 2): T3 = Arr(i, 3)
    If xD.exists(T & "") Then '字典有無E欄資料
        Arr(i, 4) = T & xD(T & "") + 1 & "-" & T & xD(T & "") + T3 '第2次以上，依規則編號放入Arr
        xD(T & "") = xD(T & "") + T3 'C欄(kg)累加裝入字典
    Else
        Arr(i, 4) = T & "1-" & T & T3  '第1次出現，依規則編號放入Arr
        xD(T & "") = T3 'C欄(kg)裝入字典
    End If
Next
Range("A1").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub
作者: john2006168    時間: 2021-4-23 09:48

回復 15# samwang

看到.,辛苦了.
作者: Andy2483    時間: 2023-3-16 16:19

本帖最後由 Andy2483 於 2023-3-16 16:23 編輯

回復 10# john2006168


    謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,請前輩參考,請各位前輩指教

執行前:
[attach]35968[/attach]

執行結果:
[attach]35969[/attach]

Option Explicit
Sub Test4()
Dim Brr, Y, N&, i&, xR As Range, T$
'↑宣告變數:(Brr,Y)是通用型變數,(N,i)是長整數變數,
'xR是儲存格變數,T是字串變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Set xR = Range([E1], [A65536].End(3))
'↑令xR這儲存格變數是 [E1]到A欄最後有內容儲存格
Brr = xR
'↑令Brr這通用型變數是二維陣列,以xR變數值帶入
For i = 2 To UBound(Brr)
'↑設順迴圈!i從2到 Brr縱向最大索引列號
   T = Brr(i, 5): N = Y(T) + 1
   '↑令這字串變數是 i迴圈列第5欄Brr陣列值,
   '令N這長整數變數是 T變數查Y字典回傳的item值+1
   Y(T) = Y(T) + Brr(i, 3)
   '↑令Y字典中以T變數為key的item值,累加i迴圈列第3欄Brr陣列值
   Brr(i, 4) = T & N & "-" & T & Y(T)
   '↑令i迴圈列第4欄Brr陣列值是 T變數連接N變數,
   '再連接"-",續連接T變數,最後連接(T變數在Y字典的item值),
   '這是字串
Next
xR = Brr
'↑令xR變數(原儲存格)值是 Brr陣列值
Set Y = Nothing: Erase Brr
'↑令釋放變數
End Sub



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