返回列表 上一主題 發帖

[分享] 判斷出現不同批號幾次

回復 1# jsc0518

請測試看看,謝謝

Sub test()
Dim Arr, xD, xD1, T1, TT, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([c1], [a65536].End(3))
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1): TT = Arr(i, 1) & Arr(i, 2)
    If xD.Exists(TT) Then
        xD(TT & "") = xD(TT & "") + 1
        xD(T1 & "") = xD(TT & "")
    Else
        xD(TT & "") = 1: xD(T1 & "") = 1
    End If
    xD1(T1 & "") = xD1(T1 & "") + Arr(i, 3)
Next
Arr = Range([g2], [f65536].End(3))
For i = 1 To UBound(Arr)
    Arr(i, 1) = xD(Arr(i, 1) & "")
    Arr(i, 2) = xD1(Arr(i, 1) & "")
Next
Range("g2").Resize(UBound(Arr)) = Arr
End Sub

TOP

回復 5# jsc0518

請再試看看,謝謝

Sub test2()
Dim Arr, xD, xD1, T1, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([c1], [a65536].End(3))
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1)
    xD(T1 & "") = xD(T1 & "") + 1
    xD1(T1 & "") = xD1(T1 & "") + Arr(i, 3)
Next
Arr = Range([g2], [f65536].End(3))
For i = 1 To UBound(Arr)
    T1 = Arr(i, 1)
    Arr(i, 1) = xD(T1 & "")
    Arr(i, 2) = xD1(T1 & "")
Next
Range("g2").Resize(UBound(Arr), 2) = Arr
End Sub

TOP

回復 5# jsc0518

不好意思,看了其他大大解答,終於了解您的需求了,6樓程式請忽略,下面程式請再測試看看,謝謝。

Sub test3()
Dim Arr, xD, xD1, T1, TT, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([c1], [a65536].End(3))
For i = 2 To UBound(Arr)
     T1 = Arr(i, 1): TT = Arr(i, 1) & Arr(i, 2)
     If Not xD.Exists(TT) Then
         xD(TT & "") = xD(TT & "") + 1
         xD(T1 & "") = xD(T1 & "") + xD(TT & "")
     End If
     xD1(T1 & "") = xD1(T1 & "") + Arr(i, 3)
Next
Arr = Range([g2], [f65536].End(3))
For i = 1 To UBound(Arr)
    T1 = Arr(i, 1)
    Arr(i, 1) = xD(T1 & "")
    Arr(i, 2) = xD1(T1 & "")
Next
Range("g2").Resize(UBound(Arr), 2) = Arr
End Sub

TOP

本帖最後由 samwang 於 2021-6-18 07:49 編輯

回復 11# jsc0518

請測試看看,謝謝。

Sub test4()
Dim Arr, xD, xD1, T1, TT, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([繳庫量!e1], [繳庫量!y65536].End(3))
For i = 2 To UBound(Arr)
     T1 = Arr(i, 1): TT = Arr(i, 1) & Arr(i, 2)
     If Not xD.Exists(TT) Then
         xD(TT & "") = xD(TT & "") + 1
         xD(T1 & "") = xD(T1 & "") + xD(TT & "")
     End If
     xD1(T1 & "") = xD1(T1 & "") + Arr(i, 21)
Next
With Sheets("Analysis")
    Arr = .Range(.[b2], .[a65536].End(3))

    For i = 1 To UBound(Arr)
        T1 = Arr(i, 1)
        Arr(i, 1) = xD(T1 & "")
        Arr(i, 2) = xD1(T1 & "")
    Next
    .Range("b2").Resize(UBound(Arr), 2) = Arr
End With

End Sub

TOP

回復 14# jsc0518

需要把程式放在模組裡面,謝謝

插入-->模組-->程式
擷取.PNG

TOP

回復 14# jsc0518

程式修改如下,要放在工作表或模組都可以,請再測試看看,謝謝。

Sub test5()
Dim Arr, xD, xD1, T1, TT, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
With Sheets("繳庫量")
    Arr = .Range(.[e1], .[y65536].End(3))
    For i = 2 To UBound(Arr)
         T1 = Arr(i, 1): TT = Arr(i, 1) & Arr(i, 2)
         If Not xD.Exists(TT) Then
             xD(TT & "") = xD(TT & "") + 1
             xD(T1 & "") = xD(T1 & "") + xD(TT & "")
         End If
         xD1(T1 & "") = xD1(T1 & "") + Arr(i, 21)
    Next
End With
With Sheets("Analysis")
    Arr = .Range(.[b2], .[a65536].End(3))
    For i = 1 To UBound(Arr)
        T1 = Arr(i, 1)
        Arr(i, 1) = xD(T1 & "")
        Arr(i, 2) = xD1(T1 & "")
    Next
    .Range("b2").Resize(UBound(Arr), 2) = Arr
End With
End Sub

TOP

回復 17# jsc0518


無差別,只是寫法要注意,謝謝

例如:
工作表1模組: Range("A1")
一般模組:       Sheets("工作表1").Range("A1")

TOP

准大只用了一個字典就解決了,而且效率也很快,感謝准大分享,謝謝。

TOP

        靜思自在 : 人的眼睛長在前面,只看到別人的缺點,絲毫看不到自己的缺點。
返回列表 上一主題