12
返回列表 上一主題 發帖

[發問] 兩表資料重複對比並數量相乘

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2025-11-6 09:52 | 顯示全部帖子

[發問] 兩表資料重複對比並數量相乘



有兩個表 Read & Data

Data 是資料檔案
Read 是程式執行檔案


執行程式規則：
Read 表 灰色部分是原有資料，保留。
Read 表 A 欄  對比 Data 表 H 欄，
若吻合，複製 Data 表 對應的一列資料到 Read 表 A 欄最後一列後, 數量 Read 表  Qty * Data 表 Qty （如藍色部分）
完成後，再重複一次
Read 表 A 欄  對比 Data 表 H 欄，
若吻合，複製 Data 表 對應的一列資料到 Read 表 A 欄最後一列後, 數量 Read 表  Qty * Data 表 Qty （如綠色色部分）
收藏 分享

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
2#
發表於 2025-11-6 12:04 | 顯示全部帖子
回復  198188


    請前輩上傳範例檔
Andy2483 發表於 2025-11-6 11:10


前輩，附上範例

範例.rar (10.69 KB)

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
3#
發表於 2025-11-6 14:34 | 顯示全部帖子
  1. Option Explicit
  2. Sub TEST()
  3. Dim arr, Brr, Z, K, i&, j%, N&
  4. Set Z = CreateObject("Scripting.Dictionary")
  5. Brr = [Read!A1].CurrentRegion
  6. For i = 2 To UBound(Brr): Z(Brr(i, 1)) = Val(Brr(i, 3)): Next
  7. Brr = Range([Data!A1], [Data!A1].CurrentRegion.Offset(UBound(Brr)))
  8. For i = 2 To UBound(Brr)
  9.    If Z.Exists(Brr(i, 8)) Then
  10.       Z(Brr(i, 1) & "/") = i
  11.       Brr(i, 3) = Z(Brr(i, 8)) * Val(Brr(i, 3))
  12.    End If
  13.    If Z.Exists(Brr(i, 8) & "/") Then
  14.       Z(Brr(i, 8) & "//") = i
  15.       Brr(i, 3) = Brr(Z(Brr(i, 8) & "/"), 3) * Val(Brr(i, 3))
  16.    End If
  17. Next
  18. For Each K In Z.Keys
  19.    If InStr(K, "/") Then
  20.       N = N + 1
  21.       For j = 1 To UBound(Brr, 2): Brr(N, j) = Brr(Z(K), j): Next
  22.       'Brr(N, 3) = "=" & Brr(N, 3)
  23.    End If
  24. Next
  25. arr = Sheets("Read").UsedRange
  26. Sheets("Read").Range("A" & UBound(arr) + 1).Resize(N, UBound(Brr, 2)) = Brr
  27. End Sub
複製代碼
回復  198188


    謝謝前輩發表此主題與範例,後學學習方案如下,請前輩參考

Option Explicit
Sub  ...
Andy2483 發表於 2025-11-6 14:16


前輩我修改如上。

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
4#
發表於 2025-11-6 15:12 | 顯示全部帖子
回復  198188


    謝謝前輩發表此主題與範例,後學學習方案如下,請前輩參考

Option Explicit
Sub  ...
Andy2483 發表於 2025-11-6 14:16


Brr = Range([Data!A1], [Data!A1].CurrentRegion.Offset(UBound(Brr)))

請問前輩，這句如果想改
xFile = "Data Base.xlsx"
sheets ("Data")
應該如何套入？

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
5#
發表於 2025-11-6 17:48 | 顯示全部帖子
With Workbooks("Data Base.xlsx").Sheets("Data")
   Brr = .Range(.[A1], .[A1].CurrentRegion.Of ...
Andy2483 發表於 2025-11-6 15:38



前輩，如果數量每一輪的數量都用  前一輪的總數量 *  Data Base 的數量，應該如何更改？
舉例
本檔灰色是原本數量，
E1204 共有6個

第一輪運行
E1204 共有6個
E1204 對應 A1122
A1122 有 2 行, 如下
A1122  2 * 6 =12
A1122  3 * 6 =18

第二輪運行
A1122 共有30個

A1122 對應 B1236
B1236 有 1 行, 如下
B1236    2 * 30 = 60

範例.rar (12.52 KB)

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
6#
發表於 2025-11-7 10:42 | 顯示全部帖子
回復  198188


    請前輩自行試試寫一段代碼先把Data 同號相加，再將Read比對2次Data
Andy2483 發表於 2025-11-6 19:04
  1. Brr = [Read!A1].CurrentRegion
  2. For i = 2 To UBound(Brr): Z(Brr(i, 1)) = Val(Brr(i, 3)): Next
  3. N = 1
  4. For i = 2 To UBound(Brr)
  5.    If Z.Exists(Brr(i, 1)) Then
  6.           Z(Brr(N, 3)) = Z(Brr(N, 3)) + Brr(i, 3)
  7.       End If
  8. Next
複製代碼
我嘗試將灰色的數量記入字典，頭四個成功記入，但是後面不懂得加總，

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
7#
發表於 2025-11-7 12:01 | 顯示全部帖子
本帖最後由 198188 於 2025-11-7 12:02 編輯
回復  198188


    請前輩自行試試寫一段代碼先把Data 同號相加，再將Read比對2次Data
Andy2483 發表於 2025-11-6 19:04



  前輩，第一步 將Read 表的 CODE 放入字典，Qty 也放入字典並相同 Code 加總，這部分我試了很多次，都不成功。
請指點一下後學。

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
8#
發表於 2025-11-7 14:52 | 顯示全部帖子
本帖最後由 198188 於 2025-11-7 14:55 編輯
  1. Sub sumdata()
  2. Dim i As Long
  3. Dim n As Long
  4. Dim ar, arr, brr As Variant
  5. Dim dict As New Dictionary

  7. ar = [A1].CurrentRegion
  8. Set dict = CreateObject("Scripting.Dictionary")

  10. With dict
  11. For i = 1 To UBound(ar, 1)
  12. .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 3)
  13. Next i
  14. arr = Array(.Keys, .Items)
  15. n = .Count
  16. End With

  18. [O1].Resize(n, 2).Value = Application.Transpose(arr)


  21. brr = Sheets("Data").UsedRange
  22. For i = 2 To UBound(brr)
  23.    If dict(brr(i, 8)) > 0 Then
  24.       m = m + 1
  25.       For j = 1 To 13: brr(m, j) = brr(i, j): Next
  26.       brr(m, 3) = brr(m, 3) * dict(brr(i, 8))
  27.          
  28.    End If
  29. Next
  30. If m > 0 Then Sheets("Read").[A13].Resize(m, 13) = brr: m = 0 Else MsgBox "Frame per Dwg_Nothing"

  32. End Sub
複製代碼
回復  198188


    請前輩自行試試寫一段代碼先把Data 同號相加，再將Read比對2次Data
Andy2483 發表於 2025-11-6 19:04


前輩，我完成第一輪了。

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
9#
發表於 2025-11-7 15:32 | 顯示全部帖子
回復  198188


    請前輩自行試試寫一段代碼先把Data 同號相加，再將Read比對2次Data
Andy2483 發表於 2025-11-6 19:04
  1. Sub sumdata()
  2. Dim i As Long
  3. Dim n As Long
  4. Dim ar, arr, brr As Variant
  5. Dim dict As New Dictionary
  6. .Column("O:P").Delete
  7. ar = [A1].CurrentRegion
  8. lastRow = UBound(ar)
  9. Set dict = CreateObject("Scripting.Dictionary")

  11. With dict
  12. For i = 1 To UBound(ar, 1)
  13. .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 3)
  14. Next i
  15. arr = Array(.Keys, .Items)
  16. n = .Count
  17. End With
  18. [O1].Resize(n, 2).Value = Application.Transpose(arr)

  20. brr = Sheets("Data").UsedRange
  21. For i = 2 To UBound(brr)
  22.    If dict(brr(i, 8)) > 0 Then
  23.       m = m + 1
  24.       For j = 1 To 13: brr(m, j) = brr(i, j): Next
  25.       brr(m, 3) = brr(m, 3) * dict(brr(i, 8))
  26.    
  27.    End If
  28. Next
  29. If m > 0 Then Sheets("Read").Range("A" & lastRow + 1).Resize(m, 13) = brr: m = 0

  31. ar = Range("A" & lastRow + 1).CurrentRegion
  32. lastRow1 = UBound(ar)
  33. ar = Range("A" & lastRow & ":M" & lastRow1)
  34. Set dict = CreateObject("Scripting.Dictionary")

  36. With dict
  37. For i = 2 To UBound(ar, 1)
  38. .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 3)
  39. Next i
  40. arr = Array(.Keys, .Items)
  41. n = .Count
  42. End With
  43. [O1].Resize(n, 2).Value = Application.Transpose(arr)

  45. brr = Sheets("Data").UsedRange
  46. For i = 1 To UBound(brr)
  47.    If dict(brr(i, 8)) > 0 Then
  48.       m = m + 1
  49.       For j = 1 To 13: brr(m, j) = brr(i, j): Next
  50.       brr(m, 3) = brr(m, 3) * dict(brr(i, 8))
  51.    
  52.    End If
  53. Next
  54. If m > 0 Then Sheets("Read").Range("A" & lastRow1 + 1).Resize(m, 13) = brr: m = 0

  56. End Sub
複製代碼
前輩，已經完成，請指點。

TOP

198188

帖子
582 
主題
75 
精華
0 
積分
682 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2026-4-13 
10#
發表於 2025-11-7 17:40 | 顯示全部帖子
本帖最後由 198188 於 2025-11-7 17:44 編輯
回復  198188


    謝謝前輩指導,很多沒看過的,後學執行出現偵錯,請前輩指點
Andy2483 發表於 2025-11-7 16:40



   

前輩，需要去 工具 =>設定引用項目 => Microsoft Scripting Runtime
附上範例

範例.rar (12.52 KB)

TOP

        靜思自在 : 脾氣嘴巴不好，心地再好也不能算是好人。
12
返回列表 上一主題