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

標題: 請問sumif 改寫成字典或是array讓執行速度變快 [打印本頁]

作者: s3526369 時間: 2022-9-13 09:48 標題: 請問sumif 改寫成字典或是array讓執行速度變快

以下是我目前可以執行但是運算時間有點久
請問有更好的方法可以去取代嗎

Sub 倉庫庫存合計()
Dim X, i As Long
For i = 4 To Sheets("倉庫庫存").[A1000].End(3).Row
X = WorksheetFunction.SumIf(Sheets("入庫明細").Range("O2:O600"), Sheets("倉庫庫存").Cells(i, 1), Sheets("入庫明細").Range("R2:R600")) '入庫合計
DA = WorksheetFunction.SumIf(Sheets("全機種BOM").Range("P:P"), Sheets("倉庫庫存").Cells(i, 1), Sheets("全機種BOM").Range("Z:Z")) '公司總需求
BA = WorksheetFunction.SumIf(Sheets("A需求").Range("A:A"), Sheets("倉庫庫存").Cells(i, 1), Sheets("A需求").Range("H:H")) 'A倉
bb = WorksheetFunction.SumIf(Sheets("b需求").Range("A:A"), Sheets("倉庫庫存").Cells(i, 1), Sheets("B需求").Range("H:H")) 'B倉
BC = WorksheetFunction.SumIf(Sheets("指圖明細").Range("F:F"), Sheets("倉庫庫存").Cells(i, 1), Sheets("指圖明細").Range("L:L")) '總出貨
FY = WorksheetFunction.SumIf(Sheets("出庫明細").Range("H2:H600"), Sheets("廢料倉").Cells(i, 1) & Sheets("廢料倉").Cells(1, 1), Sheets("出庫明細").Range("I2:I600")) '廢料
FX = WorksheetFunction.SumIf(Sheets("指圖明細").Range("F2:F2000"), Sheets("廢料倉").Cells(i, 1), Sheets("指圖明細").Range("K2:K2000")) '廢料
EY = WorksheetFunction.SumIf(Sheets("出庫明細").Range("H2:H600"), Sheets("退庫").Cells(i, 1) & Sheets("退庫").Cells(1, 1), Sheets("出庫明細").Range("I2:I600")) '退庫
QA = Sheets("倉庫庫存").Cells(i, 4) + Sheets("倉庫庫存").Cells(i, 5) ' ''倉庫庫存
QB = Sheets("倉庫庫存").Cells(i, "K") + Sheets("倉庫庫存").Cells(i, "L")
Sheets("倉庫庫存").Cells(i, 5) = X '入庫合計
Sheets("倉庫庫存").Cells(i, "M") = BC ''總出貨
Sheets("倉庫庫存").Cells(i, "C") = DA ' 總需求
Sheets("倉庫庫存").Cells(i, "H") = QA - QB - BA - bb - BC ''公司倉
Sheets("倉庫庫存").Cells(i, "I") = bb ''B倉
Sheets("倉庫庫存").Cells(i, "J") = BA ''A倉
Sheets("倉庫庫存").Cells(i, "G") = QA - QB - BC ''總數
Sheets("廢料倉").Cells(i, 3) = FY + FX
Sheets("退庫").Cells(i, 3) = EY
Next i
End Sub

複製代碼

作者: samwang 時間: 2022-9-13 18:09

回復 1# s3526369

請問方便附上檔案嗎? 謝謝

作者: s3526369 時間: 2022-9-14 08:31

回復 2# samwang

好的那我簡化一些再貼上來

作者: s3526369 時間: 2022-9-14 08:51

回復 2# samwang

[attach]35209[/attach]

檔案在這再麻煩你看看

作者: Andy2483 時間: 2022-9-14 14:40

本帖最後由 Andy2483 於 2022-9-14 14:41 編輯

回復 4# s3526369

謝謝前輩發表此主題
後學習得很多技巧
1.WorksheetFunction.SumIf的用法
2.工作表放入字典
3.陣列局部放入儲存格

後學的以下方法只節省一點點時間,供前輩參考
拋磚引玉,後學也想學厲害的前輩們的指導

Sub TEST_1()
Application.ScreenUpdating = False
Dim X, i As Long, DA, BA, bb, BC, FY, FX, EY, QA, QB, T
Dim S, Srr, Arr, Ac, xR, c, xC
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
'0 1 2 3 4 5
S = Split("入庫明細,全機種BOM,A需求,b需求,指圖明細,倉庫庫存", ",")
For i = 0 To UBound(S)
Set Srr(i) = Sheets(S(i))
Next
Ac = Srr(5).Cells(Rows.Count, 1).End(3).Row
Arr = Range(Srr(5).[N4], Srr(5).Cells(Ac, 1))
For i = 1 To Ac - 3
xR = Arr(i, 1)
Arr(i, 5) = WorksheetFunction.SumIf(Srr(0).[O:O], xR, Srr(0).[R:R]) '入庫合計
Arr(i, 3) = WorksheetFunction.SumIf(Srr(1).[P:P], xR, Srr(1).[Z:Z]) '公司總需求
Arr(i, 10) = WorksheetFunction.SumIf(Srr(2).[A:A], xR, Srr(2).[H:H]) 'A倉
Arr(i, 9) = WorksheetFunction.SumIf(Srr(3).[A:A], xR, Srr(3).[H:H]) 'B倉
Arr(i, 13) = WorksheetFunction.SumIf(Srr(4).[F:F], xR, Srr(4).[L:L]) '總出貨
QA = Arr(i, 4) + Arr(i, 5) ' ''倉庫庫存
QB = Arr(i, 11) + Arr(i, 12)
Arr(i, 8) = QA - QB - Arr(i, 10) - Arr(i, 9) - Arr(i, 13) ''公司倉
Arr(i, 7) = QA - QB - Arr(i, 13) ''總數
Next i
c = Array(, 3, 5, 7, 8, 9, 10, 13)
For i = 1 To UBound(c)
Srr(5).Cells(4, c(i)).Resize(UBound(Arr), 1) = Application.Index(Arr, , c(i))
Next
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

複製代碼

作者: s3526369 時間: 2022-9-14 18:36

回復 5# Andy2483

厲害了~感謝前輩幫我解惑
我再好好研究研究!

作者: samwang 時間: 2022-9-15 08:07

回復 samwang

檔案在這再麻煩你看看
s3526369 發表於 2022-9-14 08:51

請測試看看，謝謝
Sub test()
Dim Arr, xD, xD1, xD2, xD3, xD4, T$, i&, QA, QB
Set xD = CreateObject("Scripting.Dictionary") '入庫合計
Set xD1 = CreateObject("Scripting.Dictionary")  '公司總需求
Set xD2 = CreateObject("Scripting.Dictionary")  'A倉
Set xD3 = CreateObject("Scripting.Dictionary")  'B倉
Set xD4 = CreateObject("Scripting.Dictionary")  '總出貨
TM = Timer
With Sheets("入庫明細")
Arr = .Range(.[r1], .[o65536].End(3))
For i = 2 To UBound(Arr)
      T = Arr(i, 1): xD(T) = xD(T) + Arr(i, 4) '入庫合計
Next
End With
With Sheets("全機種BOM")
Arr = .Range(.[z1], .[p65536].End(3))
For i = 2 To UBound(Arr)
      T = Arr(i, 1): xD1(T) = xD1(T) + Arr(i, 11) '公司總需求
Next
End With
With Sheets("A需求")
Arr = .Range(.[h1], .[a65536].End(3))
For i = 4 To UBound(Arr)
      T = Arr(i, 1): xD2(T) = xD2(T) + Arr(i, 8)  'A倉
Next
End With
With Sheets("B需求")
Arr = .Range(.[h1], .[a65536].End(3))
For i = 4 To UBound(Arr)
      T = Arr(i, 1): xD3(T) = xD3(T) + Arr(i, 8)  'B倉
Next
End With
With Sheets("指圖明細")
Arr = .Range(.[L1], .[f65536].End(3))
For i = 4 To UBound(Arr)
      T = Arr(i, 1): xD4(T) = xD4(T) + Arr(i, 7)  '總出貨
Next
End With
With Sheets("倉庫庫存")
Arr = .Range(.[m3], .[a65536].End(3))
For i = 2 To UBound(Arr)
      T = Arr(i, 1)
      QA = Arr(i, 4) + Arr(i, 5) ' ''倉庫庫存
      QB = Arr(i, 11) + Arr(i, 12)
      Arr(i, 5) = xD(T) '入庫合計
      Arr(i, 13) = xD4(T)  '總出貨
      Arr(i, 3) = xD1(T) '總需求
      Arr(i, 8) = QA - QB - xD2(T) - xD3(T) - xD4(T)  '公司倉
      Arr(i, 9) = xD3(T) 'B倉
      Arr(i, 10) = xD2(T)  'A倉
      Arr(i, 7) = QA - QB - xD4(T)  '總數
Next
.[a3].Resize(UBound(Arr), 13) = Arr
End With
MsgBox "共耗時：" & Timer - TM & " 秒"
End Sub

作者: Andy2483 時間: 2022-9-15 08:37

回復 7# samwang

太快了! 強!
謝謝前輩分享!

作者: s3526369 時間: 2022-9-15 08:47

回復 7# samwang

好厲害!
這也是一種方法,速度又更快了!
謝謝前輩!

作者: s3526369 時間: 2022-9-15 09:53

回復 7# samwang

前輩請問一下如果是要判斷兩個條件
例如:

With Sheets("入庫明細")
Arr = .Range(.[r1], .[o65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): xD(T) = xD(T) + Arr(i, 4) '入庫合計
Next
End With

複製代碼

加入判斷倉庫別的話

作者: samwang 時間: 2022-9-15 10:48

回復 samwang

前輩請問一下如果是要判斷兩個條件
例如:加入判斷倉庫別的話
s3526369 發表於 2022-9-15 09:53

不太了解您的意思，是這樣嗎?

T = Arr(i, 1) & "|" & Arr(i, ??)

作者: s3526369 時間: 2022-9-15 12:46

本帖最後由 s3526369 於 2022-9-15 12:56 編輯

回復 11# samwang

With Sheets("入庫明細")
Arr = .Range(.[r1], .[o65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): xD(T) = xD(T) + Arr(i, 4) '入庫合計
Next
End With

複製代碼

目前是判斷料號 = 入庫明細料號加總後填入到倉庫庫存的進貨合計欄位
我的意思是判斷料號後還要再判斷入庫明細裡的倉庫(入)欄位,符合是"公司倉"才可以填入
數量 , 料號 , 料號 , 倉別 , 倉別
WorksheetFunction.SumIf(Sheets("入庫明細").Range("H2:H600"), Sheets("A需求").Cells(i, 1) ,Sheets("入庫明細").Range("O2:O600"), "公司倉",Sheets("入庫明細").Range("S2:S600") )

作者: Andy2483 時間: 2022-9-15 14:13

本帖最後由 Andy2483 於 2022-9-15 14:19 編輯

回復 4# s3526369

謝謝前輩發表此主題
謝謝samwang前輩指導
謝謝准提部林前輩的字典中的字典
後學習得很多技巧
1.字典名字參數化
2.資料倒入字典迴圈化
3..IIF 函數補 0

Option Explicit
Sub TEST_2()
Application.ScreenUpdating = False
Dim x, i, QA, QB, T, S, Srr, Arr, Ac, xR, C
Dim Trr, Brr, Crr, Rs, Rqs, Rqn, Ras, Ran, B
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
Set Trr = CreateObject("Scripting.Dictionary")
S = Split("入庫明細,全機種BOM,A需求,b需求,指圖明細,倉庫庫存", ",")
For i = 0 To UBound(S)
Set Srr(i) = Sheets(S(i))
Set Trr(i) = CreateObject("Scripting.Dictionary")
Next
Rs = Rows.Count
Ac = Srr(5).Cells(Rs, 1).End(3).Row
Arr = Range(Srr(5).[N4], Srr(5).Cells(Ac, 1))
C = Array(15, 18, 16, 26, 1, 8, 1, 8, 6, 12)
For i = 0 To UBound(C) Step 2
Set Rqs = Srr(i / 2).Cells(1, C(i))
Set Rqn = Srr(i / 2).Cells(Rs, C(i)).End(3)
Brr = Srr(i / 2).Range(Rqs, Rqn)
Set Ras = Srr(i / 2).Cells(1, C(i + 1))
Set Ran = Srr(i / 2).Cells(Rqn.Row, C(i + 1))
Crr = Srr(i / 2).Range(Ras, Ran)
For x = 1 To UBound(Brr)
B = Brr(x, 1)
Trr(i / 2)(B) = Trr(i / 2)(B) + Crr(x, 1)
Next
Next
For i = 1 To Ac - 3
xR = Arr(i, 1)
Arr(i, 5) = IIf(Trr(0)(xR), Trr(0)(xR), 0) '入庫合計
Arr(i, 3) = IIf(Trr(1)(xR), Trr(1)(xR), 0) '公司總需求
Arr(i, 10) = IIf(Trr(2)(xR), Trr(2)(xR), 0) 'A倉
Arr(i, 9) = IIf(Trr(3)(xR), Trr(3)(xR), 0) 'B倉
Arr(i, 13) = IIf(Trr(4)(xR), Trr(4)(xR), 0) '總出貨
QA = Arr(i, 4) + Arr(i, 5) '倉庫庫存
QB = Arr(i, 11) + Arr(i, 12)
Arr(i, 8) = QA - QB - Arr(i, 10) - Arr(i, 9) - Arr(i, 13) '公司倉
Arr(i, 7) = QA - QB - Arr(i, 13) '總數
Next i
C = Array(, 3, 5, 7, 8, 9, 10, 13)
For i = 1 To UBound(C)
Srr(5).Cells(4, C(i)).Resize(UBound(Arr), 1) = Application.Index(Arr, , C(i))
Next
Set Arr = Nothing
Set Brr = Nothing
Set Crr = Nothing
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

複製代碼

作者: samwang 時間: 2022-9-15 14:17

回復 samwang 目前是判斷料號 = 入庫明細料號加總後填入到倉庫庫存的進貨合計欄位
我的意思是判斷料 ...
s3526369 發表於 2022-9-15 12:46

不好意思，不太了解需求，可否附上說明演練實際數據，謝謝

作者: s3526369 時間: 2022-9-15 14:43

回復 14# samwang
不好意思
原本資料是sumif 改成

With Sheets("入庫明細")
Arr = .Range(.[r1], .[o65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): xD(T) = xD(T) + Arr(i, 4) '入庫合計
Next
End With

複製代碼

如果是換成sumifs 要判斷兩個條件成立的話

作者: s3526369 時間: 2022-9-15 14:53

回復 13# Andy2483

謝謝前輩,這個執行速度也很快,但是內容就比較複雜需要好好好研究

作者: s3526369 時間: 2022-9-15 16:42

回復 14# samwang

我重新上傳我修改後的檔案
我有增加了些條件

作者: Andy2483 時間: 2022-9-15 16:45

回復 12# s3526369

請教前輩:
1.Sheets("入庫明細").Range("H2:H600") 這欄位是隱藏而且被保護了
2.Sheets("入庫明細").儲存格[H2]內容是 1501343公司倉 !跟此主題是什麼關係?
3.這 WorksheetFunction.SumIfs的值要放哪裡?

作者: s3526369 時間: 2022-9-15 17:07

回復 18# Andy2483

我有重新修改了
檔案在17樓
可以看看
謝謝

作者: samwang 時間: 2022-9-16 08:01

回復 samwang
不好意思
原本資料是sumif 改成如果是換成sumifs 要判斷兩個條件成立的話
s3526369 發表於 2022-9-15 14:43

是這樣嗎? 請測試看看，謝謝
With Sheets("入庫明細")
Arr = .Range(.[S1], .[o65536].End(3))
For i = 2 To UBound(Arr)
      If Arr(i, 5) = "公司倉" Then '是公司倉-->貨物編號累加R欄的Qty
         T = Arr(i, 1): xD(T) = xD(T) + Arr(i, 4) '入庫合計
      End If
Next
End With

作者: Andy2483 時間: 2022-9-16 08:28

回復 20# samwang

前輩早安
1.事情應該不是這麼單純,多出了幾個表了!
2.WorksheetFunction.SumIfs WorksheetFunction.SumIf 兩種都有
3.題主前輩感覺很心急!腦筋動得很快,馬上套用,又馬上出新問題! 也蠻有趣!
4.很榮幸可以在這論壇跟前輩學習,謝謝指導分享!

作者: s3526369 時間: 2022-9-16 08:44

回復 20# samwang

感謝前輩~
是得沒錯最簡單的方法,可以用IF就好,一時沒有想到

作者: s3526369 時間: 2022-9-16 08:50

回復 21# Andy2483

早安~ 有找到解決得辦法了
Sub TEST_2()
Application.ScreenUpdating = False
Dim x, i, QA, QB, T, S, Srr, Arr, Ac, xR, C
Dim Trr, Brr, Crr, Rs, Rqs, Rqn, Ras, Ran, B
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
Set Trr = CreateObject("Scripting.Dictionary")
S = Split("入庫明細,全機種BOM,A需求,b需求,指圖明細,倉庫庫存", ",")
For i = 0 To UBound(S)
Set Srr(i) = Sheets(S(i))
Set Trr(i) = CreateObject("Scripting.Dictionary")
Next
Rs = Rows.Count
Ac = Srr(5).Cells(Rs, 1).End(3).Row
Arr = Range(Srr(5).[N4], Srr(5).Cells(Ac, 1))
C = Array(15, 18, 16, 26, 1, 8, 1, 8, 6, 12)
For i = 0 To UBound(C) Step 2
Set Rqs = Srr(i / 2).Cells(1, C(i))
Set Rqn = Srr(i / 2).Cells(Rs, C(i)).End(3)
Brr = Srr(i / 2).Range(Rqs, Rqn)
Set Ras = Srr(i / 2).Cells(1, C(i + 1))
Set Ran = Srr(i / 2).Cells(Rqn.Row, C(i + 1))
Crr = Srr(i / 2).Range(Ras, Ran)
For x = 1 To UBound(Brr)
B = Brr(x, 1)
Trr(i / 2)(B) = Trr(i / 2)(B) + Crr(x, 1)
Next
Next
For i = 1 To Ac - 3
xR = Arr(i, 1)
Arr(i, 5) = IIf(Trr(0)(xR), Trr(0)(xR), 0) '入庫合計
Arr(i, 3) = IIf(Trr(1)(xR), Trr(1)(xR), 0) '公司總需求
Arr(i, 10) = IIf(Trr(2)(xR), Trr(2)(xR), 0) 'A倉
Arr(i, 9) = IIf(Trr(3)(xR), Trr(3)(xR), 0) 'B倉
Arr(i, 13) = IIf(Trr(4)(xR), Trr(4)(xR), 0) '總出貨
QA = Arr(i, 4) + Arr(i, 5) '倉庫庫存
QB = Arr(i, 11) + Arr(i, 12)
Arr(i, 8) = QA - QB - Arr(i, 10) - Arr(i, 9) - Arr(i, 13) '公司倉
Arr(i, 7) = QA - QB - Arr(i, 13) '總數
Next i
C = Array(, 3, 5, 7, 8, 9, 10, 13)
For i = 1 To UBound(C)
Srr(5).Cells(4, C(i)).Resize(UBound(Arr), 1) = Application.Index(Arr, , C(i))
Next
Set Arr = Nothing
Set Brr = Nothing
Set Crr = Nothing
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub
想請問一下紅色這段,辦法解釋原因嗎,看不太懂

作者: Andy2483 時間: 2022-9-16 09:58

回復 23# s3526369

這段不適合前輩的新範例檔了!條件不一樣
C = Array(15, 18, 16, 26, 1, 8, 1, 8, 6, 12)  '這是O,R,P,ZA,H,A,H,F,L欄位
For i = 0 To UBound(C) Step 2 '兩兩一組去指定工作表指定欄位
Set Rqs = Srr(i / 2).Cells(1, C(i)) 'i / 2是指定每個工作表  i=0時 Rqs是[O1]
Set Rqn = Srr(i / 2).Cells(Rs, C(i)).End(3)
Brr = Srr(i / 2).Range(Rqs, Rqn)
Set Ras = Srr(i / 2).Cells(1, C(i + 1))   ' i=0時 Ras是[R1]
Set Ran = Srr(i / 2).Cells(Rqn.Row, C(i + 1))
Crr = Srr(i / 2).Range(Ras, Ran)
For x = 1 To UBound(Brr)
   B = Brr(x, 1)
   Trr(i / 2)(B) = Trr(i / 2)(B) + Crr(x, 1)
Next
Next

作者: s3526369 時間: 2022-9-16 10:47

回復 24# Andy2483

謝謝前輩,原來如此多一樣可以學習

作者: Andy2483 時間: 2022-9-16 14:24

回復 17# s3526369

這範例整理了一下,並且把SumIf的改為SumIfs 發現疑問
1.TC,TD,UC,UD這幾個變數跟執行結果是沒有關係,所以程式多跑了0.5秒
2.退庫,廢料倉這兩個工作表也是跟執行結果是沒有關係

請教前輩:
A.是範例不完整?
B.還是要忽略上述兩項疑問!簡化如下的程式碼
C.其他
如果是A 請提供新的範例,如果是B 後學繼續以下列程式碼研習縮短執行時間,
如果是C 請再說明

Sub 倉庫庫存合計COPY3()
Application.ScreenUpdating = False
Dim x, i As Long, DA, BA, bb, BC, FY, FX, EY, QA, QB, T
Dim S, Srr, Arr, Ac, xR, C, xC
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
'0 1 2 3 4 5 6 7
S = Split("入庫明細,全機種BOM,A需求,b需求,指圖明細,出庫明細,公司盤點,倉庫庫存", ",")
For i = 0 To UBound(S)
Set Srr(i) = Sheets(S(i))
Next
Ac = Srr(7).Cells(Rows.Count, 1).End(3).Row
Arr = Range(Srr(7).[N4], Srr(7).Cells(Ac, 1))
For i = 1 To Ac - 3
xR = Arr(i, 1)
Arr(i, 5) = WorksheetFunction.SumIfs(Srr(0).[R:R], Srr(0).[O:O], xR) '入庫合計 CCCCCCC
TA = WorksheetFunction.SumIfs(Srr(0).[R:R], Srr(0).[O:O], xR, Srr(0).[S:S], "A倉") '入庫明細-A
UA = WorksheetFunction.SumIfs(Srr(0).[R:R], Srr(0).[O:O], xR, Srr(0).[S:S], "B倉") '入庫明細-B
Arr(i, 3) = WorksheetFunction.SumIfs(Srr(1).[Z:Z], Srr(1).[P:P], xR) '公司總需求 CCCCCCC
'TC = WorksheetFunction.SumIfs(Srr(1).[U:U], Srr(1).[P:P], xR, Srr(1).[T:T], "A倉") '全BOM-殘單A需求
'TD = WorksheetFunction.SumIfs(Srr(1).[V:V], Srr(1).[P:P], xR, Srr(1).[T:T], "A倉") '全BOM-訂單A需求
'UC = WorksheetFunction.SumIfs(Srr(1).[U:U], Srr(1).[P:P], xR, Srr(1).[T:T], "B倉") '全BOM-殘單B需求
'UD = WorksheetFunction.SumIfs(Srr(1).[V:V], Srr(1).[P:P], xR, Srr(1).[T:T], "B倉") '全BOM-訂單B需求
TE = WorksheetFunction.SumIfs(Srr(4).[L:L], Srr(4).[F:F], xR, Srr(4).[J:J], "A倉") '指圖明細-A
UE = WorksheetFunction.SumIfs(Srr(4).[L:L], Srr(4).[F:F], xR, Srr(4).[J:J], "B倉") '指圖明細-B
Arr(i, 13) = WorksheetFunction.SumIfs(Srr(4).[L:L], Srr(4).[F:F], xR) '指圖明細-總出貨 CCCCCC
PA = WorksheetFunction.SumIfs(Srr(4).[K:K], Srr(4).[F:F], xR) '指圖明細-廢料 CCCCCC
TB = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "A倉") '出庫明細-A
UB = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "B倉") '出庫明細-B
Arr(i, 11) = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "退庫") '出庫明細-退庫
PB = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "廢料倉") '出庫明細-廢料
Arr(i, 4) = WorksheetFunction.SumIfs(Srr(6).[G:G], Srr(6).[A:A], xR) '上月盤點數
TF = WorksheetFunction.SumIfs(Srr(6).[F:F], Srr(6).[A:A], xR) '公司盤點-A倉
TG = WorksheetFunction.SumIfs(Srr(6).[K:K], Srr(6).[A:A], xR) '公司盤點-調整A倉
UF = WorksheetFunction.SumIfs(Srr(6).[E:E], Srr(6).[A:A], xR) '公司盤點-B倉
UG = WorksheetFunction.SumIfs(Srr(6).[J:J], Srr(6).[A:A], xR) '公司盤點-調整B倉
Arr(i, 10) = TF + TG + TA + TB - TE 'A倉
Arr(i, 9) = UF + UG + UA + UB - UE 'B倉
Arr(i, 12) = PA + PB
XA = 0
If Arr(i, 3) > 0 Then
XA = Arr(i, 4) + Arr(i, 5) - Arr(i, 11) - Arr(i, 12) - Arr(i, 3)
If XA > 0 Then
XA = 0
End If
End If
Arr(i, 6) = XA
QA = Arr(i, 4) + Arr(i, 5) ' ''倉庫庫存
QB = Arr(i, 11) + Arr(i, 12)
Arr(i, 8) = QA - QB - Arr(i, 10) - Arr(i, 9) - Arr(i, 13) ''公司倉
Arr(i, 7) = QA - QB - Arr(i, 13) ''總數
Next i
C = Array(, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)
For i = 1 To UBound(C)
Srr(7).Cells(4, C(i)).Resize(UBound(Arr), 1) = Application.Index(Arr, , C(i))
Next
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

複製代碼

作者: Andy2483 時間: 2022-9-16 15:43

回復 17# s3526369

謝謝前輩提供此範例
習得變數名參數化
以下程式碼供參考
待前輩樓上的回覆

Option Explicit
Sub 倉庫庫存合計COPY5()
Application.ScreenUpdating = False
Dim x&, i&, 值(1 To 17) As Long
Dim S, Srr, Arr, Ac, xR, C, T, XA, QA, QB
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
'0 1 2 3 4 5 6 7
S = Split("入庫明細,全機種BOM,A需求,b需求,指圖明細,出庫明細,公司盤點,倉庫庫存", ",")
For i = 0 To UBound(S)
Set Srr(i) = Sheets(S(i))
Next
Ac = Srr(7).Cells(Rows.Count, 1).End(3).Row
Arr = Range(Srr(7).[N4], Srr(7).Cells(Ac, 1))
For i = 1 To Ac - 3
xR = Arr(i, 1)
值(1) = WorksheetFunction.SumIfs(Srr(0).[R:R], Srr(0).[O:O], xR) '入庫合計C
值(2) = WorksheetFunction.SumIfs(Srr(0).[R:R], Srr(0).[O:O], xR, Srr(0).[S:S], "A倉") '入庫明細-A
值(3) = WorksheetFunction.SumIfs(Srr(0).[R:R], Srr(0).[O:O], xR, Srr(0).[S:S], "B倉") '入庫明細-B
值(4) = WorksheetFunction.SumIfs(Srr(1).[Z:Z], Srr(1).[P:P], xR) '公司總需求C
值(5) = WorksheetFunction.SumIfs(Srr(4).[L:L], Srr(4).[F:F], xR, Srr(4).[J:J], "A倉") '指圖明細-A
值(6) = WorksheetFunction.SumIfs(Srr(4).[L:L], Srr(4).[F:F], xR, Srr(4).[J:J], "B倉") '指圖明細-B
值(7) = WorksheetFunction.SumIfs(Srr(4).[L:L], Srr(4).[F:F], xR) '指圖明細-總出貨C
值(8) = WorksheetFunction.SumIfs(Srr(4).[K:K], Srr(4).[F:F], xR) '指圖明細-廢料C
值(9) = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "A倉") '出庫明細-A
值(10) = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "B倉") '出庫明細-B
值(11) = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "退庫") '出庫明細-退庫
值(12) = WorksheetFunction.SumIfs(Srr(5).[R:R], Srr(5).[O:O], xR, Srr(5).[S:S], "廢料倉") '出庫明細-廢料
值(13) = WorksheetFunction.SumIfs(Srr(6).[G:G], Srr(6).[A:A], xR) '上月盤點數
值(14) = WorksheetFunction.SumIfs(Srr(6).[F:F], Srr(6).[A:A], xR) '公司盤點-A倉
值(15) = WorksheetFunction.SumIfs(Srr(6).[K:K], Srr(6).[A:A], xR) '公司盤點-調整A倉
值(16) = WorksheetFunction.SumIfs(Srr(6).[E:E], Srr(6).[A:A], xR) '公司盤點-B倉
值(17) = WorksheetFunction.SumIfs(Srr(6).[J:J], Srr(6).[A:A], xR) '公司盤點-調整B倉
Arr(i, 5) = 值(1)
Arr(i, 3) = 值(4)
Arr(i, 13) = 值(7)
Arr(i, 11) = 值(11)
Arr(i, 4) = 值(13)
Arr(i, 10) = 值(14) + 值(15) + 值(2) + 值(9) - 值(5) 'A倉
Arr(i, 9) = 值(16) + 值(17) + 值(3) + 值(10) - 值(6) 'B倉
Arr(i, 12) = 值(8) + 值(12)
XA = 0
If 值(4) > 0 Then
XA = 值(13) + 值(1) - 值(11) - Arr(i, 12) - 值(4)
If XA > 0 Then
XA = 0
End If
End If
Arr(i, 6) = XA
QA = 值(13) + 值(1) '倉庫庫存
QB = 值(11) + Arr(i, 12)
Arr(i, 8) = QA - QB - Arr(i, 10) - Arr(i, 9) - 值(7) '公司倉
Arr(i, 7) = QA - QB - 值(7) '總數
Next i
C = Array(, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)
For i = 1 To UBound(C)
Srr(7).Cells(4, C(i)).Resize(UBound(Arr), 1) = Application.Index(Arr, , C(i))
Next
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

複製代碼

作者: s3526369 時間: 2022-9-16 16:24

回復 26# Andy2483

前輩你好~
是範例不完整,可以先忽略掉沒有關係!

作者: s3526369 時間: 2022-9-16 16:42

回復 7# samwang

前輩你好~請問套用程式後,倉庫庫存A.B欄的公式變成值,有解決的辦法嗎?

作者: s3526369 時間: 2022-9-16 16:45

回復 27# Andy2483

前輩~你看看這個,我套用samwang前輩方式去整理出來!
執行速度很快,但是目前遇到的問題,就是欄位原本是公式會變成值的問題,
這可能要等samwang前輩來解!

作者: s3526369 時間: 2022-9-16 17:29

回復 30# s3526369
要看模組 Module2

作者: samwang 時間: 2022-9-16 19:09

回復 Andy2483

前輩~你看看這個,我套用samwang前輩方式去整理出來!
執行速度很快,但是目前遇到的問題 ...
s3526369 發表於 2022-9-16 16:45

附件看不出哪裡有公式，後學光看那些程式碼就快....，您都可以套用寫出，建議將原來有公式區可以轉成VBA，
這樣也可以提升效率，謝謝

作者: s3526369 時間: 2022-9-17 00:14

本帖最後由 s3526369 於 2022-9-17 00:16 編輯

回復 32# samwang

前輩你好~我倉庫庫存A.B是連結材料表的資料,我重新上傳附件!

作者: samwang 時間: 2022-9-17 06:57

回復 samwang

前輩你好~我倉庫庫存A.B是連結材料表的資料,我重新上傳附件!
s3526369 發表於 2022-9-17 00:14

請測試看看，謝謝

作者: Andy2483 時間: 2022-9-17 09:56

太厲害了!
33# 祥龍十八掌
34# 打通任督二脈

作者: Andy2483 時間: 2022-9-17 16:48

回復 33# s3526369

提醒前輩
下方紅字處須改為2

Sub 倉庫庫存()
Dim Arr, xD, xD1, xD2, xD3, xD4, xD5, xD6, xD7, T$, i&, QA, QB
Set xD = CreateObject("Scripting.Dictionary") '入庫合計
Set xD1 = CreateObject("Scripting.Dictionary")  '公司總需求
Set xD2 = CreateObject("Scripting.Dictionary")  'A倉
Set xD3 = CreateObject("Scripting.Dictionary")  'B倉
Set xD4 = CreateObject("Scripting.Dictionary")  '總出貨
Set xD5 = CreateObject("Scripting.Dictionary")  '盤點數'
Set xD6 = CreateObject("Scripting.Dictionary") '退庫
Set xD7 = CreateObject("Scripting.Dictionary")  '廢料
TM = Timer
With Sheets("入庫明細")
Arr = .Range(.[r1], .[o65536].End(3))
For i = 2 To UBound(Arr)
      T = Arr(i, 1): xD(T) = xD(T) + Arr(i, 4) '入庫合計
Next
End With
With Sheets("全機種BOM")
Arr = .Range(.[Z1], .[p65536].End(3))
For i = 2 To UBound(Arr)
      T = Arr(i, 1): xD1(T) = xD1(T) + Arr(i, 11) '公司總需求
Next
End With
With Sheets("A需求")
Arr = .Range(.[h1], .[A65536].End(3))
For i = 4 To UBound(Arr)
      T = Arr(i, 1): xD2(T) = xD2(T) + Arr(i, 8)  'A倉
Next
End With
With Sheets("B需求")
Arr = .Range(.[h1], .[A65536].End(3))
For i = 4 To UBound(Arr)
      T = Arr(i, 1): xD3(T) = xD3(T) + Arr(i, 8)  'B倉
Next
End With
With Sheets("指圖明細")
Arr = .Range(.[L1], .[f65536].End(3))
For i = 4 To UBound(Arr)
      T = Arr(i, 1): xD4(T) = xD4(T) + Arr(i, 7)  '總出貨
Next
End With
With Sheets("公司盤點")
Arr = .Range(.[G1], .[A65536].End(3))
For i = 4 To UBound(Arr)
      T = Arr(i, 1): xD5(T) = xD5(T) + Arr(i, 7)  '公司盤點
Next
End With

With Sheets("退庫")
Arr = .Range(.[C1], .[A65536].End(3))
For i = 3 To UBound(Arr)
      T = Arr(i, 1): xD6(T) = xD6(T) + Arr(i, 3)  'B倉
Next
End With
With Sheets("廢料倉")
Arr = .Range(.[C1], .[A65536].End(3))
For i = 3 To UBound(Arr)
      T = Arr(i, 1): xD7(T) = xD7(T) + Arr(i, 3)  'B倉
Next
End With

With Sheets("倉庫庫存")
Arr = .Range(.[m3], .[A65536].End(3))
For i = 2 To UBound(Arr)
      T = Arr(i, 1)
      QA = xD5(T) + xD(T) ' ''倉庫庫存
      QB = xD6(T) + xD7(T)
      Arr(i, 5) = xD(T) '入庫合計
      Arr(i, 13) = xD4(T)  '總出貨
      Arr(i, 3) = xD1(T) '總需求
      Arr(i, 8) = QA - QB - xD2(T) - xD3(T) - xD4(T)  '公司倉
      Arr(i, 9) = xD3(T) 'B倉
      Arr(i, 10) = xD2(T)  'A倉
      Arr(i, 7) = QA - QB - xD4(T)  '總數
      Arr(i, 4) = xD5(T)
      Arr(i, 11) = xD6(T)
      Arr(i, 12) = xD7(T)

      If Arr(i, 3) > 0 Then
      XA = xD5(T) + xD(T) - xD6(T) - xD7(T) - Arr(i, 3)
         If XA >= 0 Then XA = "0"
      Else
         XA = "0"
      End If
      If xD(T) = 0 Then Arr(i, 5) = "0"
      If xD5(T) = 0 Then Arr(i, 4) = "0"
      If xD1(T) = 0 Then Arr(i, 3) = "0"
      If xD4(T) = 0 Then Arr(i, 13) = "0"
Arr(i, 6) = XA
Next
.[a3].Resize(UBound(Arr), 13) = Arr
End With
'MsgBox "共耗時：" & Timer - TM & " 秒"
End Sub

作者: Andy2483 時間: 2022-9-17 16:58

謝謝兩位前輩
今天習得
1.倒入字典迴圈化
2.預設2條件吻合才加總

Option Explicit
Sub 倉庫庫存_20220917()
Application.ScreenUpdating = False
Dim x&, i&, 值(1 To 17) As Long, QA, QB, T, S, Srr, Arr, Ac, xR, C
Dim Trr, Brr, Crr, Rs, Rq1s, Rq1n, Ras, Ran, B, 欄d, 特rr, Drr
Dim Rq2s, Rq2n, XA
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
Set Trr = CreateObject("Scripting.Dictionary")
Set 特rr = CreateObject("Scripting.Dictionary")
' 0 1 2 3 4 5 6 7 8
S = Split("倉庫庫存,入庫明細,全機種BOM,A需求,B需求,指圖明細,公司盤點,退庫,廢料倉", ",")
For i = 1 To UBound(S)
Set Srr(i) = Sheets(S(i))
Set Trr(i) = CreateObject("Scripting.Dictionary")
Set 特rr(i) = CreateObject("Scripting.Dictionary")
Next
Rs = Rows.Count
Ac = Sheets(S(0)).Cells(Rs, 1).End(3).Row
Arr = Range(Sheets(S(0)).[N4], Sheets(S(0)).Cells(Ac, 1))
'vS, vC,zS, zC,xS,xC,zS, zC,zV
特rr(1) = Array("", 1, 18, 1, 15, 0, 1, 1, 99, "") '入庫合計
特rr(2) = Array("", 2, 26, 2, 16, 0, 1, 2, 99, "") '公司總需求
特rr(3) = Array("", 3, 8, 3, 1, 0, 1, 3, 99, "") 'A倉
特rr(4) = Array("", 4, 8, 4, 1, 0, 1, 4, 99, "") 'B倉
特rr(5) = Array("", 5, 12, 5, 6, 0, 1, 5, 99, "") '總出貨
特rr(6) = Array("", 6, 7, 6, 1, 0, 1, 6, 99, "") '公司盤點
特rr(7) = Array("", 7, 3, 7, 1, 0, 1, 7, 99, "") 'B倉
特rr(8) = Array("", 8, 3, 8, 1, 0, 1, 8, 99, "") 'B倉
For i = 1 To UBound(S)
Set Rq1s = Srr(特rr(i)(3)).Cells(1, 特rr(i)(4))
Set Rq1n = Srr(特rr(i)(3)).Cells(Rs, 特rr(i)(4)).End(3)
Brr = Srr(特rr(i)(3)).Range(Rq1s, Rq1n)
Set Rq2s = Srr(特rr(i)(7)).Cells(1, 特rr(i)(8))
Set Rq2n = Srr(特rr(i)(7)).Cells(Rq1n.Row, 特rr(i)(8))
Drr = Srr(特rr(i)(7)).Range(Rq2s, Rq2n)
Set Ras = Srr(特rr(i)(1)).Cells(1, 特rr(i)(2))
Set Ran = Srr(特rr(i)(1)).Cells(Rq1n.Row, 特rr(i)(2))
Crr = Srr(特rr(i)(1)).Range(Ras, Ran)
For x = 1 To UBound(Brr)
B = Brr(x, 1)
If InStr(Drr(x, 1), 特rr(i)(9)) Or Drr(x, 1) & 特rr(i)(9) = "" Then
Trr(i)(B) = Trr(i)(B) + Crr(x, 1)
End If
Next
Next
For i = 1 To Ac - 3
xR = Arr(i, 1)
QA = Trr(1)(xR) + Trr(6)(xR) '倉庫庫存
QB = Trr(7)(xR) + Trr(8)(xR)
Arr(i, 5) = Trr(1)(xR) '入庫合計
Arr(i, 13) = Trr(5)(xR) '總出貨
Arr(i, 3) = Trr(2)(xR) '總需求
Arr(i, 8) = QA - QB - Trr(3)(xR) - Trr(4)(xR) - Trr(5)(xR) '公司倉
Arr(i, 9) = Trr(4)(xR) 'B倉
Arr(i, 10) = Trr(3)(xR) 'A倉
Arr(i, 7) = QA - QB - Trr(5)(xR) '總數
Arr(i, 4) = Trr(6)(xR)
Arr(i, 11) = Trr(7)(xR)
Arr(i, 12) = Trr(8)(xR)
If Arr(i, 3) > 0 Then
XA = Trr(6)(xR) + Trr(1)(xR) - Trr(7)(xR) - Trr(8)(xR) - Arr(i, 3)
If XA >= 0 Then XA = 0
Else
XA = 0
End If
If Trr(1)(xR) = 0 Then Arr(i, 5) = 0
If Trr(6)(xR) = 0 Then Arr(i, 4) = 0
If Trr(2)(xR) = 0 Then Arr(i, 3) = 0
If Trr(5)(xR) = 0 Then Arr(i, 13) = 0
Arr(i, 6) = XA
Next i
C = Array(, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)
For i = 1 To UBound(C)
Sheets(S(0)).Cells(4, C(i)).Resize(UBound(Arr), 1) = Application.Index(Arr, , C(i))
Next
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

複製代碼

作者: Andy2483 時間: 2022-9-19 10:35

回復 37# Andy2483

謝謝論壇
謝謝各位前輩
異想天開!測試OK
Set Srr(i) = Sheets(S(i))
改為
Set Srr(i) = Sheets(S(i)).Cells
後方的Cells都可以省略

Option Explicit
Sub 倉庫庫存_20220919()
Application.ScreenUpdating = False
Dim x&, i&, QA, QB, T, S, Srr, Arr, Ac, xR, C
Dim Trr, Brr, Crr, Rs, Rq1s, Rq1n, Ras, Ran, B, 特rr, Drr
Dim Rq2s, Rq2n, XA
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
Set Trr = CreateObject("Scripting.Dictionary")
Set 特rr = CreateObject("Scripting.Dictionary")
' 0 1 2 3 4 5 6 7 8
S = Split("倉庫庫存,入庫明細,全機種BOM,A需求,B需求,指圖明細,公司盤點,退庫,廢料倉", ",")
For i = 1 To UBound(S)
Set Srr(i) = Sheets(S(i)).Cells
Set Trr(i) = CreateObject("Scripting.Dictionary")
Set 特rr(i) = CreateObject("Scripting.Dictionary")
Next
Rs = Rows.Count
Ac = Sheets(S(0)).Cells(Rs, 1).End(3).Row
Arr = Range(Sheets(S(0)).[N4], Sheets(S(0)).Cells(Ac, 1))
'vS, vC,zS, zC,xS,xC,zS, zC,zV
特rr(1) = Array("", 1, 18, 1, 15, 0, 1, 1, 99, "") '入庫合計
特rr(2) = Array("", 2, 26, 2, 16, 0, 1, 2, 99, "") '公司總需求
特rr(3) = Array("", 3, 8, 3, 1, 0, 1, 3, 99, "") 'A倉
特rr(4) = Array("", 4, 8, 4, 1, 0, 1, 4, 99, "") 'B倉
特rr(5) = Array("", 5, 12, 5, 6, 0, 1, 5, 99, "") '總出貨
特rr(6) = Array("", 6, 7, 6, 1, 0, 1, 6, 99, "") '公司盤點
特rr(7) = Array("", 7, 3, 7, 1, 0, 1, 7, 99, "") 'B倉
特rr(8) = Array("", 8, 3, 8, 1, 0, 1, 8, 99, "") 'B倉
For i = 1 To UBound(S)
Set Rq1s = Srr(特rr(i)(3))(1, 特rr(i)(4))
Set Rq1n = Srr(特rr(i)(3))(Rs, 特rr(i)(4)).End(3)
Brr = Srr(特rr(i)(3)).Range(Rq1s, Rq1n)
Set Rq2s = Srr(特rr(i)(7))(1, 特rr(i)(8))
Set Rq2n = Srr(特rr(i)(7))(Rq1n.Row, 特rr(i)(8))
Drr = Srr(特rr(i)(7)).Range(Rq2s, Rq2n)
Set Ras = Srr(特rr(i)(1))(1, 特rr(i)(2))
Set Ran = Srr(特rr(i)(1))(Rq1n.Row, 特rr(i)(2))
Crr = Srr(特rr(i)(1)).Range(Ras, Ran)
For x = 1 To UBound(Brr)
B = Brr(x, 1)
If InStr(Drr(x, 1), 特rr(i)(9)) Or Drr(x, 1) & 特rr(i)(9) = "" Then
Trr(i)(B) = Trr(i)(B) + Crr(x, 1)
End If
Next
Next
For i = 1 To Ac - 3
xR = Arr(i, 1)
QA = Trr(1)(xR) + Trr(6)(xR) '倉庫庫存
QB = Trr(7)(xR) + Trr(8)(xR)
Arr(i, 5) = Trr(1)(xR) '入庫合計
Arr(i, 13) = Trr(5)(xR) '總出貨
Arr(i, 3) = Trr(2)(xR) '總需求
Arr(i, 8) = QA - QB - Trr(3)(xR) - Trr(4)(xR) - Trr(5)(xR) '公司倉
Arr(i, 9) = Trr(4)(xR) 'B倉
Arr(i, 10) = Trr(3)(xR) 'A倉
Arr(i, 7) = QA - QB - Trr(5)(xR) '總數
Arr(i, 4) = Trr(6)(xR)
Arr(i, 11) = Trr(7)(xR)
Arr(i, 12) = Trr(8)(xR)
If Arr(i, 3) > 0 Then
XA = Trr(6)(xR) + Trr(1)(xR) - Trr(7)(xR) - Trr(8)(xR) - Arr(i, 3)
If XA >= 0 Then XA = 0
Else
XA = 0
End If
If Trr(1)(xR) = 0 Then Arr(i, 5) = 0
If Trr(6)(xR) = 0 Then Arr(i, 4) = 0
If Trr(2)(xR) = 0 Then Arr(i, 3) = 0
If Trr(5)(xR) = 0 Then Arr(i, 13) = 0
Arr(i, 6) = XA
Next i
C = Array(, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13)
For i = 1 To UBound(C)
Sheets(S(0)).Cells(4, C(i)).Resize(UBound(Arr), 1) = Application.Index(Arr, , C(i))
Next
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

複製代碼

作者: Andy2483 時間: 2022-9-19 13:19

回復 33# s3526369

提醒前輩關於 Sub A需求()
1.Arr(i, 3) 沒有填入值
2.xD3字典創建後沒有被使用
3.求出的值與初始的範例倉庫合計.rar 有差異

作者: Andy2483 時間: 2022-9-19 13:25

謝謝兩位前輩
今天習得
1.倒入字典迴圈化
2.預設2條件吻合才加總
Andy2483 發表於 2022-9-17 16:58

2.預設2條件吻合才加總套入 A需求可以用

Option Explicit
Sub A需求_20220919()
Application.ScreenUpdating = False
Dim x&, i&, QA, QB, T, S, Srr, Arr, Ac, xR, C
Dim Trr, Brr, Crr, Rs, Rq1s, Rq1n, Ras, Ran, B, 特rr, Drr
Dim Rq2s, Rq2n, XA
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
Set Trr = CreateObject("Scripting.Dictionary")
Set 特rr = CreateObject("Scripting.Dictionary")
' 0 1 2 3 4 5 6 7
S = Split("A需求,入庫明細,出庫明細,全機種BOM,指圖明細,公司盤點,公司盤點,公司盤點", ",")
For i = 1 To UBound(S)
Set Srr(i) = Sheets(S(i)).Cells
Set Trr(i) = CreateObject("Scripting.Dictionary")
Set 特rr(i) = CreateObject("Scripting.Dictionary")
Next
Rs = Rows.Count
Ac = Sheets(S(0)).Cells(Rs, 1).End(3).Row
Arr = Range(Sheets(S(0)).[H4], Sheets(S(0)).Cells(Ac, 1))
'vS, vC,zS, zC,xS,xC,zS, zC,zV
特rr(1) = Array("", 1, 18, 1, 15, 0, 1, 1, 19, "A倉") '入庫合計
特rr(2) = Array("", 2, 18, 2, 15, 0, 1, 2, 19, "A倉") '出庫合計
特rr(3) = Array("", 3, 26, 3, 16, 0, 1, 3, 20, "A倉") '全機種BOM-總需求
特rr(4) = Array("", 4, 12, 4, 6, 0, 1, 4, 10, "A倉") '指圖明細-總出貨
特rr(5) = Array("", 5, 6, 5, 1, 0, 1, 5, 99, "") '公司盤點-A倉
特rr(6) = Array("", 6, 11, 6, 1, 0, 1, 6, 99, "") '公司盤點-A倉調整
特rr(7) = Array("", 7, 7, 7, 1, 0, 1, 7, 99, "") '盤點表
For i = 1 To UBound(S)
Set Rq1s = Srr(特rr(i)(3))(1, 特rr(i)(4))
Set Rq1n = Srr(特rr(i)(3))(Rs, 特rr(i)(4)).End(3)
Brr = Srr(特rr(i)(3)).Range(Rq1s, Rq1n)
Set Rq2s = Srr(特rr(i)(7))(1, 特rr(i)(8))
Set Rq2n = Srr(特rr(i)(7))(Rq1n.Row, 特rr(i)(8))
Drr = Srr(特rr(i)(7)).Range(Rq2s, Rq2n)
Set Ras = Srr(特rr(i)(1))(1, 特rr(i)(2))
Set Ran = Srr(特rr(i)(1))(Rq1n.Row, 特rr(i)(2))
Crr = Srr(特rr(i)(1)).Range(Ras, Ran)
For x = 1 To UBound(Brr)
B = Brr(x, 1)
If InStr(Drr(x, 1), 特rr(i)(9)) Or Drr(x, 1) & 特rr(i)(9) = "" Then
Trr(i)(B) = Trr(i)(B) + Crr(x, 1)
End If
Next
Next
For i = 1 To Ac - 3
xR = Arr(i, 1)
Arr(i, 4) = Trr(7)(xR)
Arr(i, 5) = Trr(3)(xR)
Arr(i, 6) = Trr(1)(xR) + Trr(2)(xR)
Arr(i, 8) = Trr(5)(xR) + Trr(6)(xR)
If Trr(3)(xR) = 0 Then Arr(i, 5) = 0
If Trr(7)(xR) = 0 Then Arr(i, 4) = 0
If Trr(1)(xR) + Trr(2)(xR) = 0 Then Arr(i, 6) = 0
If Trr(5)(xR) + Trr(6)(xR) = 0 Then Arr(i, 8) = 0
Arr(i, 7) = Trr(5)(xR) + Trr(6)(xR) + Trr(1)(xR) + Trr(2)(xR) - Trr(3)(xR)
If Arr(i, 7) >= 0 Then Arr(i, 7) = 0
Next i
Sheets(S(0)).[A4].Resize(UBound(Arr), 8) = Arr
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

複製代碼

作者: s3526369 時間: 2022-9-20 17:06

回復 34# samwang

感謝前輩 ~測試可以!

作者: s3526369 時間: 2022-9-20 17:11

回復 36# Andy2483
謝謝你有修改了
回復 40# Andy2483
前輩~也太厲害了!很多種方法,有點看不太懂,但慢慢研究應該可以理解!

作者: Andy2483 時間: 2022-10-21 11:56

本帖最後由 Andy2483 於 2022-10-21 12:00 編輯

回復 40# Andy2483
今天回顧此帖把此帖的心得註解一下
當初是亂試成功會跑的! 真的是矇上的!
請各位前輩指正並指導!

Option Explicit
Sub A需求_20220919()
Application.ScreenUpdating = False
Dim x&, i&, QA, QB, T, S, Srr, Arr, Ac, xR, C
Dim Trr, Brr, Crr, Rs, Rq1s, Rq1n, Ras, Ran, B, 特rr, Drr
Dim Rq2s, Rq2n, XA
'↑宣告變數
T = Timer
Set Srr = CreateObject("Scripting.Dictionary")
Set Trr = CreateObject("Scripting.Dictionary")
Set 特rr = CreateObject("Scripting.Dictionary")
'↑令Srr,Trr,特rr是字典
S = Split("A需求,入庫明細,出庫明細,全機種BOM,指圖明細,公司盤點,公司盤點,公司盤點", ",")
'↑令S是一維陣列!裝入工作表名字串用 "," 符號拆解成8個字串,從0~7
For i = 1 To UBound(S)
'↑設順迴圈設定後7個字串是分別是三個字典的KEY
Set Srr(i) = Sheets(S(i)).Cells
'↑Srr的Item是7個工作表
Set Trr(i) = CreateObject("Scripting.Dictionary")
'↑Trr的Item是7個新字典
Set 特rr(i) = CreateObject("Scripting.Dictionary")
'↑特rr的Item是7個新字典
Next
Rs = Rows.Count
'↑令Rs是這表的極限列數 1048576
Ac = Sheets(S(0)).Cells(Rs, 1).End(3).Row
'↑令Ac是 "A需求"表的A欄最後一個有內容格
Arr = Range(Sheets(S(0)).[H4], Sheets(S(0)).Cells(Ac, 1))
'↑令Arr是陣列裝入 Ac 與 "A需求"表的[H4] ,
'這兩個對角格涵蓋的方正最小區域儲存格值
特rr(1) = Array("", 1, 18, 1, 15, 0, 1, 1, 19, "A倉") '入庫合計
'↑將陣列值當ITEM,KEY是0~9 倒入特rr(1)這字典中的字典
'↑字典中的字典KEY 0 的ITEM 是"" 空字元,是後面程序沒有用到的
'純粹是要讓後面程序從key 1 開始引用
'↑字典中的字典KEY 1 ,KEY 2 ITEM(1, 18)
',是用來指引第1個表 "入庫明細" 表要取R欄資料
'↑字典中的字典KEY 3 ,KEY 4 ITEM(1, 15)
',是用來指引第1個表 "入庫明細" 表要取O欄資料
'↑字典中的字典KEY 5 ,KEY 6 ITEM(0, 1)
',是備用的!如果樓主的需求在結果表還要增加條件用的
'↑字典中的字典KEY 7 ,KEY 8 ITEM(1, 19)
',是用來指引第1個表 "入庫明細" 表要取S欄資料
'↑字典中的字典KEY 9 ITEM是 "A倉" (第二個判斷條件關鍵字)

'↓後續依上述類推, 裡面的 99 是CU欄的意思
特rr(2) = Array("", 2, 18, 2, 15, 0, 1, 2, 19, "A倉") '出庫合計
特rr(3) = Array("", 3, 26, 3, 16, 0, 1, 3, 20, "A倉") '全機種BOM-總需求
特rr(4) = Array("", 4, 12, 4, 6, 0, 1, 4, 10, "A倉")  '指圖明細-總出貨
特rr(5) = Array("", 5, 6, 5, 1, 0, 1, 5, 99, "") '公司盤點-A倉
特rr(6) = Array("", 6, 11, 6, 1, 0, 1, 6, 99, "")  '公司盤點-A倉調整
特rr(7) = Array("", 7, 7, 7, 1, 0, 1, 7, 99, "")  '盤點表

For i = 1 To UBound(S)
'↑設外順迴圈從 1 到 S陣列的最後一個 7
Set Rq1s = Srr(特rr(i)(3))(1, 特rr(i)(4))
Set Rq1n = Srr(特rr(i)(3))(Rs, 特rr(i)(4)).End(3)
Brr = Srr(特rr(i)(3)).Range(Rq1s, Rq1n)
'↑令Brr是陣列將條件1的儲存格值資料倒入,當被搜尋的關鍵字

Set Rq2s = Srr(特rr(i)(7))(1, 特rr(i)(8))
Set Rq2n = Srr(特rr(i)(7))(Rq1n.Row, 特rr(i)(8))
Drr = Srr(特rr(i)(7)).Range(Rq2s, Rq2n)
'↑令Drr是陣列將條件2的儲存格值資料倒入,當被搜尋的關鍵字

Set Ras = Srr(特rr(i)(1))(1, 特rr(i)(2))
Set Ran = Srr(特rr(i)(1))(Rq1n.Row, 特rr(i)(2))
Crr = Srr(特rr(i)(1)).Range(Ras, Ran)
'↑令Crr是陣列結果儲存格值資料倒入
For x = 1 To UBound(Brr)
'↑設內順迴圈從 1 到第1條件的最後個
   B = Brr(x, 1)
   '↑貨品編號
   If InStr(Drr(x, 1), 特rr(i)(9)) Or Drr(x, 1) & 特rr(i)(9) = "" Then
   '↑如果第二條件成立或
   '第二條件的關鍵字欄格值與特rr(i)第9個ITEM 組合的字串是空字元

    '因為如果沒有第二條件判斷的工作表資料!也要創立字典供後續引用
   ''此範例CU欄一定是空格,與特rr(i)(9) = ""組合字串也是空格!
   '所以第二條件一定會成立!
   '因為第一條件就是貨品編號是字典一定會納入
      Trr(i)(B) = Trr(i)(B) + Crr(x, 1)
       '↑條件成立就把貨品編號當key去除重複,結果儲存格值累加當item
   End If
Next
Next
For i = 1 To Ac - 3
'↑設順迴圈將資料帶入或計算後再帶入!
xR = Arr(i, 1)
Arr(i, 4) = Trr(7)(xR)
Arr(i, 5) = Trr(3)(xR)
Arr(i, 6) = Trr(1)(xR) + Trr(2)(xR)
Arr(i, 8) = Trr(5)(xR) + Trr(6)(xR)
If Trr(3)(xR) = 0 Then Arr(i, 5) = 0
If Trr(7)(xR) = 0 Then Arr(i, 4) = 0
If Trr(1)(xR) + Trr(2)(xR) = 0 Then Arr(i, 6) = 0
If Trr(5)(xR) + Trr(6)(xR) = 0 Then Arr(i, 8) = 0
Arr(i, 7) = Trr(5)(xR) + Trr(6)(xR) + Trr(1)(xR) + Trr(2)(xR) - Trr(3)(xR)
If Arr(i, 7) >= 0 Then Arr(i, 7) = 0
Next i
Sheets(S(0)).[A4].Resize(UBound(Arr), 8) = Arr
MsgBox "共耗時：" & Timer - T & " 秒"
End Sub

作者: singo1232001 時間: 2022-10-21 17:55

Sub 倉庫庫存()
Set d = CreateObject("Scripting.Dictionary")
r = Sheets("材料表").Cells(Rows.Count, 1).End(3).Row
For Each Z In Sheets("材料表").Range("a2:a" & r)
d(Z.Value) = Z.Row - 1
Next
         '1          '2    '3    8    7 9    10    11
sA = Split("全機種BOM,公司盤點,入庫明細,A需求,B需求,退庫,廢料倉,指圖明細", ",")
sB = Split("p:z,a:g,o:r,a:h,a:h,a:c,a:c,f:l", ",")
ReDim Ar(1 To d.Count, 1 To 11) As Double

For i = 0 To UBound(sA) '放資料
Set s = Sheets(sA(i))
sC = Split(sB(i), ":")
r = s.Cells(Rows.Count, sC(0)).End(3).Row
c = Split("1,2,3,8,7,9,10,11", ",")(i)
For j = 1 To r
   If d.exists(s.Cells(j, sC(0)).Value) Then
      Ar(d(s.Cells(j, sC(0)).Value), c) = Ar(d(s.Cells(j, sC(0)).Value), c) + s.Cells(j, sC(1)).Value
   End If
Next
Next

For i = 1 To UBound(Ar)  '計算一下
a23910 = Ar(i, 3) + Ar(i, 2) - Ar(i, 9) - Ar(i, 10)
Ar(i, 6) = a23910 - Ar(i, 11) - Ar(i, 8) - Ar(i, 7)
Ar(i, 5) = a23910 - Ar(i, 11)
Ar(i, 4) = a23910 - Ar(i, 1)
If Ar(i, 4) >= 0 Then Ar(i, 4) = 0
Next
Sheets("倉庫庫存").Range("c4").Resize(UBound(Ar) - 1, 11) = Ar
End Sub

作者: singo1232001 時間: 2022-10-21 18:24

回復 44# singo1232001

'有錯修正一下

Sub 倉庫庫存2()
Set d = CreateObject("Scripting.Dictionary")
Set s = Sheets("材料表")
For Each Z In s.Range("a2:a" & s.Cells(Rows.Count, 1).End(3).Row)
d(Z.Value) = Z.Row - 1: Next
         '1          '2    '3    8    7 9    10    11
sA = Split("全機種BOM,公司盤點,入庫明細,A需求,B需求,退庫,廢料倉,指圖明細", ",")
sB = Split("p:z,a:g,o:r,a:h,a:h,a:c,a:c,f:l", ",")
ReDim Ar(1 To d.Count, 1 To 11) As Double

For i = 0 To UBound(sA) '放資料
Set s = Sheets(sA(i))
sC = Split(sB(i), ":")
Lr = s.Cells(Rows.Count, sC(0)).End(3).Row
c = Split("1,2,3,8,7,9,10,11", ",")(i)
For j = 1 To Lr
   r = s.Cells(j, sC(0)).Value
   If d.exists(r) Then Ar(d(r), c) = Ar(d(r), c) + s.Cells(j, sC(1)).Value
Next
Next

For i = 1 To UBound(Ar)  '計算一下
a23910 = Ar(i, 3) + Ar(i, 2) - Ar(i, 9) - Ar(i, 10)
Ar(i, 4) = a23910 - Ar(i, 1): If Ar(i, 4) >= 0 Then Ar(i, 4) = 0
Ar(i, 5) = a23910 - Ar(i, 11)
Ar(i, 6) = Ar(i, 5) - Ar(i, 8) - Ar(i, 7)
Next
Sheets("倉庫庫存").Range("c4").Resize(UBound(Ar) - 1, 11) = Ar
End Sub

作者: Andy2483 時間: 2022-10-25 12:40

本帖最後由 Andy2483 於 2022-10-25 12:44 編輯

回復 45# singo1232001

謝謝前輩指導
以下是今天學習心得註解!如有冒犯請見諒!
請前輩指正並指導!謝謝!
Option Explicit
Sub 倉庫庫存2()
Dim d, S, sA, sB, Ar, Z, sC, Lr, j, i, C, r, a23910
Set d = CreateObject("Scripting.Dictionary")
'↑令d是字典
Set S = Sheets("材料表")
'↑令d是物件 "材料表" 工作表!以下稱材料表
For Each Z In S.Range("a2:a" & S.Cells(Rows.Count, 1).End(3).Row)
'↑#設順迴圈令Z是材料表 [A2]到A欄的最後一格中的一格,所以Z是物件儲存格
d(Z.Value) = Z.Row - 1   '@
'↑把上述#儲存格值當key倒入d字典裡,item是Z所在的列位數-1
Next
sA = Split("全機種BOM,公司盤點,入庫明細,A需求,B需求,退庫,廢料倉,指圖明細", ",")
'↑令 sA是一維陣列,倒入用 "," 分割工作表字串組,成為8個字串從0~7
sB = Split("p:z,a:g,o:r,a:h,a:h,a:c,a:c,f:l", ",")
'↑令 sB是一維陣列,倒入用 "," 分割儲存格欄位關鍵字欄:搜尋結果欄
ReDim Ar(1 To d.Count, 1 To 11) As Double
'↑宣告 Ar是數字陣列,縱向從1 到d字典裡元素數列,橫向從1 到11欄
For i = 0 To UBound(sA) '放資料
'↑設外順迴圈,從0開始到 sA一維陣列的最後一個數 7
Set S = Sheets(sA(i))
'↑令S是物件迴圈裡的工作表以下稱(迴圈表)
sC = Split(sB(i), ":")
'↑令 sC是一維陣列倒入用 ":" 分割sB一維陣列裡的迴圈指定字串
Lr = S.Cells(Rows.Count, sC(0)).End(3).Row
'↑令 Lr是迴圈表裡指定的材料料號欄有內容的最後列數
C = Split("1,2,3,8,7,9,10,11", ",")(i)
'↑令 C是一維陣列倒入用 "," 分割結果表欄位字串
For j = 1 To Lr
'↑設內順迴圈從1 到迴圈表裡指定的材料料號欄有內容的最後列數
   r = S.Cells(j, sC(0)).Value
   '↑令r是迴圈表裡材料料號欄內迴圈儲存格的值,以下稱(關鍵字)
   If d.exists(r) Then
   '↑如果關鍵字在字典裡查得到
      Ar(d(r), C) = Ar(d(r), C) + S.Cells(j, sC(1)).Value
      '↑Ar陣列位址: @標示處字典d,key為關鍵字,的Item列位,結果表欄位
      '讓陣列中的結果值累加搜尋關鍵字得到的結果欄數量值
   End If
Next
Next
For i = 1 To UBound(Ar)  '計算一下
a23910 = Ar(i, 3) + Ar(i, 2) - Ar(i, 9) - Ar(i, 10)
Ar(i, 4) = a23910 - Ar(i, 1): If Ar(i, 4) >= 0 Then Ar(i, 4) = 0
Ar(i, 5) = a23910 - Ar(i, 11)
Ar(i, 6) = Ar(i, 5) - Ar(i, 8) - Ar(i, 7)
Next
Sheets("倉庫庫存").Range("c4").Resize(UBound(Ar), 11) = Ar
'↑將結果陣列值從"倉庫庫存"表[C4]貼入!
'用材料表的關鍵字找資料!貼到"倉庫庫存"表!風險剖大!
End Sub

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