判斷出現不同批號幾次 - Excelㄧ般區

帖子: 455
主題: 111
精華: 0
積分: 563
點名: 70
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2013-11-7
最後登錄: 2025-4-9

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章論壇贊助勳章

12^#

發表於 2021-6-17 21:41 | 只看該作者

回復 8# hcm19522
Dear hcm19522 您好！感謝您的熱心解答
使用了公式，TEST OK。但我的資料筆數過多，需花一點時間。
謝謝你歐！

Just do it.

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

13^#

發表於 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

帖子: 455
主題: 111
精華: 0
積分: 563
點名: 70
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2013-11-7
最後登錄: 2025-4-9

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章論壇贊助勳章

14^#

發表於 2021-6-18 10:13 | 只看該作者

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

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

檔案如下

111.rar (25.89 KB)

Just do it.

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

15^#

發表於 2021-6-18 10:31 | 只看該作者

回復 14# jsc0518

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

插入-->模組-->程式

擷取.PNG (61.74 KB)

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

16^#

發表於 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

帖子: 455
主題: 111
精華: 0
積分: 563
點名: 70
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2013-11-7
最後登錄: 2025-4-9

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章論壇贊助勳章

17^#

發表於 2021-6-18 12:02 | 只看該作者

回復 16# samwang

Dear samwang,
午安！您好！

可以用了，非常感謝您的幫忙！

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

再麻煩您教導，謝謝您！

Just do it.

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

18^#

發表於 2021-6-18 13:31 | 只看該作者

回復 17# jsc0518

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

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

帖子: 455
主題: 111
精華: 0
積分: 563
點名: 70
作業系統: Windows 10
軟體版本: Office 2019
閱讀權限: 50
性別: 男
註冊時間: 2013-11-7
最後登錄: 2025-4-9

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章論壇贊助勳章

19^#

發表於 2021-6-18 19:51 | 只看該作者

回復 18# samwang
知道了，謝謝您的教導。

Just do it.

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-2-15

20^#

發表於 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