Board logo

標題: [分享] 判斷出現不同批號幾次 [打印本頁]

作者: jsc0518    時間: 2021-6-16 20:11     標題: 判斷出現不同批號幾次

大家好!我有問題想請教
1.資料中有料號,所以我可以利用公式抓出來她的總數量
2.但是,每一料號下都會產出許多批號(因為是不同天產出)
3.我想要把資料變成下圖內容,右邊的欄位樣子
[attach]33400[/attach]

還請大大幫幫我
感恩


[attach]33401[/attach]
作者: aer    時間: 2021-6-17 09:52

回復 1# jsc0518
請參考
G3=SUMPRODUCT((1/COUNTIF($B$2:$B$10,$B$2:$B$10)*($A$2:$A$10=F2)))

H3=SUMIF($A$2:$A$10,F2,$C$2:$C$10)
作者: samwang    時間: 2021-6-17 11:42

回復 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
作者: jsc0518    時間: 2021-6-17 14:31

回復 2# aer
Dear aer,
您好!非常感謝您的熱心指導,公式測試後發現一個問題
當我把來源資料刪除一欄列時,公式會有錯誤,這部分是否可以修改呢?
因我的資料每月都會產出(會新增),所以欄位無法固定。
謝謝您!


[attach]33402[/attach]
作者: jsc0518    時間: 2021-6-17 14:35

回復 3# samwang
Dear samwang,
您好!感謝您熱心的指導回覆
執行VBA後,在G2~G4蘭奇數據並未因批號多寡而自動計算變動
如下圖


[attach]33403[/attach]
作者: samwang    時間: 2021-6-17 15:22

回復 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
作者: aer    時間: 2021-6-17 15:51

本帖最後由 aer 於 2021-6-17 15:59 編輯

[attach]33406[/attach]回復 4# jsc0518
改動態陣列試試


[attach]33406[/attach]
作者: hcm19522    時間: 2021-6-17 16:20

https://blog.xuite.net/hcm19522/twblog/589839401
作者: samwang    時間: 2021-6-17 20:37

回復 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
作者: jsc0518    時間: 2021-6-17 21:19

回復 7# aer

Hi 您好!感謝您的熱心幫忙,
剛剛RUN了一下語法,結果是我要的,但需要跑一些時間(連存檔案都要一點時間),我的資料目前約有2381筆
作者: jsc0518    時間: 2021-6-17 21:38

本帖最後由 jsc0518 於 2021-6-17 21:39 編輯

回復 9# samwang
Hi samwang 您好!感謝您的熱心幫忙
試過了VBA,測試OK!
想與您請教,若分做兩個工作表,資料庫的部份工作表為"繳庫量",而需分析每一料號下出現幾個批號及總數加總則放在工作表為"Analysis"
那VBA要怎麼修訂呢?
感恩!!!

如下圖
[attach]33407[/attach]


[attach]33408[/attach]


[attach]33409[/attach]
作者: jsc0518    時間: 2021-6-17 21:41

回復 8# hcm19522
Dear hcm19522 您好!感謝您的熱心解答
使用了公式,TEST OK。但我的資料筆數過多,需花一點時間。
謝謝你歐!
作者: samwang    時間: 2021-6-18 07:47

本帖最後由 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
作者: jsc0518    時間: 2021-6-18 10:13

本帖最後由 jsc0518 於 2021-6-18 10:16 編輯

回復 13# samwang
Dear samwang,
早安!您好!
感謝您的幫忙,我把語法COPY並執行,但發生了錯誤訊息:400(如下圖)
可以幫幫我嗎? ><"
拜託您了

[attach]33417[/attach]


檔案如下
[attach]33419[/attach]
作者: samwang    時間: 2021-6-18 10:31

回復 14# jsc0518

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

插入-->模組-->程式
作者: samwang    時間: 2021-6-18 10:54

回復 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
作者: jsc0518    時間: 2021-6-18 12:02

回復 16# samwang

Dear samwang,
午安!您好!

可以用了,非常感謝您的幫忙!

再與您請教幾個問題
1.要怎麼知道那些語法(指令)是使用在模組?那些語法(指令)是使用在工作表的?
2.放在模組或工作表,他們的差異是在哪裡?

再麻煩您教導,謝謝您!
作者: samwang    時間: 2021-6-18 13:31

回復 17# jsc0518


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

例如:
工作表1模組: Range("A1")
一般模組:       Sheets("工作表1").Range("A1")
作者: jsc0518    時間: 2021-6-18 19:51

回復 18# samwang
知道了,謝謝您的教導。
作者: 准提部林    時間: 2021-6-19 20:17

Sub TEST_A1()
Dim Arr, xD, T$, TT$, i&, j%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([繳庫量!e1], [繳庫量!y65536].End(3))
For i = 2 To UBound(Arr)
     T = Arr(i, 1): TT = T & "|" & Arr(i, 2)
     xD(TT) = xD(TT) + 1
     If xD(TT) = 1 Then xD(T & "/1") = xD(T & "/1") + 1
     xD(T & "/2") = xD(T & "/2") + Arr(i, 21)
Next
Arr = Range([Analysis!b1], [Analysis!a65536].End(3))
For i = 2 To UBound(Arr)
    For j = 1 To 2: Arr(i - 1, j) = xD(Arr(i, 1) & "/" & j): Next
Next
[Analysis!b2].Resize(UBound(Arr) - 1, 2) = Arr
End Sub
作者: jsc0518    時間: 2021-6-20 07:45

回復 20# 准提部林

Dear 准提部林,
早安您好!
VBA語法使用過,TEST OK。非常感謝您的熱心幫忙!
^_^
作者: samwang    時間: 2021-6-20 07:54

准大只用了一個字典就解決了,而且效率也很快,感謝准大分享,謝謝。
作者: jsc0518    時間: 2021-8-2 19:29

回復 20# 准提部林

Dear 准提部林,
晚上好!與您請教一下,
我的資料庫欄位有異動過 --> g=代號、u=總公斤數
我將您的VBA語法更改過下面的資料(紅字)
可是我改過後,卻無法帶出我想要的狀況,是否哪裡還須修改呢?


Sub Analysis()

Dim Arr, xD, T$, TT$, i&, j%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([繳庫量!g1], [繳庫量!u65536].End(3)) 'g=代號、u=總公斤數
For i = 2 To UBound(Arr)
     T = Arr(i, 1): TT = T & "|" & Arr(i, 2)
     xD(TT) = xD(TT) + 1
     If xD(TT) = 1 Then xD(T & "/1") = xD(T & "/1") + 1
     xD(T & "/2") = xD(T & "/2") + Arr(i, 15) '15=g~u
Next
Arr = Range([Analysis!b1], [Analysis!a65536].End(3))
For i = 2 To UBound(Arr)
    For j = 1 To 2: Arr(i - 1, j) = xD(Arr(i, 1) & "/" & j): Next
Next
[Analysis!b2].Resize(UBound(Arr) - 1, 2) = Arr


End Sub
作者: 准提部林    時間: 2021-8-2 20:26

回復 23# jsc0518


看來沒錯,
是哪裡的問題???

程式發生錯誤? 還是結果?
作者: jsc0518    時間: 2021-8-2 21:51

回復 24# 准提部林
Dear 准提部林,
抱歉,試出來了,我弄錯欄位了。感恩囉!




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