samwang

回復 1# john2006168


不好意思，看不太懂解規則是什麼，可否請再細說明一下，謝謝

samwang

回復 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

samwang

回復 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

samwang

回復 7# john2006168


請問PXX - 的規則如何??

samwang

回復 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

samwang

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

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