麻辣家族討論版版 - Powered by Discuz! Board

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

作者: 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 准提部林,
抱歉，試出來了，我弄錯欄位了。感恩囉！

作者: Andy2483 時間: 2022-10-31 15:15

本帖最後由 Andy2483 於 2022-10-31 15:18 編輯

回復 20# 准提部林

謝謝前輩!
以下心得註解!請前輩再指導!謝謝
Option Explicit
Sub TEST_A1()
Dim Arr, xD, T$, TT$, i&, j%
'↑宣告變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典
Arr = Range([繳庫量!e1], [繳庫量!y65536].End(3))
'↑令Arr是字典!倒入繳庫量表[E1] 與Y欄最後-有內容儲存格之間
',最小方正區域儲存格的值
For i = 2 To UBound(Arr)
'↑設順迴圈!,i從2 到Arr陣列最後一縱向列數
   T = Arr(i, 1)
   '↑令是Arr陣列迴圈列數第1縱向欄值(表裡的代號欄值)
   TT = T & "|" & Arr(i, 2)
   '↑令TT是代號 & "|" & 批號  的組合字串
   xD(TT) = xD(TT) + 1
   '↑組合字串當key!Item累加1
   If xD(TT) = 1 Then
   '↑如果組合字串的item 是 1時(TT組合字串剛到入字典時)
      xD(T & "/1") = xD(T & "/1") + 1
      '↑令代號 & "/1" 的組合字串當key!Item累加1
      '這裡的 "/1" 是為了指向結果資料的欄位數1  '@@
      '也就是有不同組合時同代號出現不同批號次數+1
   End If
   xD(T & "/2") = xD(T & "/2") + Arr(i, 21)
   '↑令代號 & "/2" 的組合字串當key!Item累加總公斤數
   '這裡的 "/2" 是為了指向結果資料的欄位數2 '@@
Next
Arr = Range([Analysis!b1], [Analysis!a65536].End(3))
'↑重新令Arr是字典!倒入 Analysis表[B1] 與A欄最後-有內容儲存格之間
',最小方正區域儲存格的值
For i = 2 To UBound(Arr)
'↑設外順迴圈!,i從2 到Arr陣列最後一縱向列數
For j = 1 To 2
'↑設內順迴圈!,j從1 到2
   Arr(i - 1, j) = xD(Arr(i, 1) & "/" & j)
   '↑用Analysis表的關鍵字搭配"/"符號與內順迴圈數當Key!
   '查字典裡的item值如上標註 @@處
   '將結果item值放在關鍵字列前一列迴圈對應欄裡!
   '因為後方 ##標示處有 -1,所以不會導致Arr最後列貼入結果!
Next
Next
[Analysis!b2].Resize(UBound(Arr) - 1, 2) = Arr '##
'將Arr陣列從Analysis表[B2]開始貼入!
'因為Resize()= Arr的方式是直接最左上角範圍的的元素!
'所以前輩才從Arr第一列開始帶入結果
'如果是後學為了保險起見!會加個Brr來裝結果!
'謝謝指導!
End Sub

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