BOM智能计算

lsfeng

要求速度快，BOM无限制增加
1.计算出每周对应MPS1*各个BOM（ABC007，EFG003，WHU123）的和                                                                                       
2.在文件夹BOM下面增加新的BOM，如XYZ001，该表智能自动计算包含新增BOM（XYZ001）                                                                                       
3.如能选择MPS文件夹中的MPS1，MPS2，MPS3（…….)单独*BOM文件夹中所有的BOM，分别得出ReqQty2,ReqQty3就算完美了
4.无任BOM的格式如何变化，只要有QTY就能智能选取该列数据与MPS1中的数据进行计算

delete_007

你是出题还是求助？
出题自己需要一份标准答案。

lsfeng

delete_007 发表于 2013-9-13 12:28
你是出题还是求助？
出题自己需要一份标准答案。

这个栏目不是题目征集吗？是求助

delete_007

请你尽早阅读版块相关规则说明：http://club.excelhome.net/thread-162093-1-1.html
求助帖我给你转移到VBA版块去。

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim Arr, myPath$, myName$, Arr1, Myr&, d, cs$, d1, k, t
   
3.     Dim nm$, Brr, y&, m&
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     Sheet1.Activate
   
8.     [d2:z5000].ClearContents
   
9.     Brr = [a1].CurrentRegion
   
10.     cs = "MPS1"
    
11.     myPath = ThisWorkbook.Path & ""
    
12.     myName = cs & ".xls"
    
13.     With GetObject(myPath & myName)
    
14.         Arr1 = .Sheets(1).Range("A1").CurrentRegion
    
15.         For i = 2 To UBound(Arr1)
    
16.             d(Arr1(i, 1)) = d(Arr1(i, 1)) & i & ","
    
17.         Next
    
18.         .Close False
    
19.     End With
    
20.     k = d.keys: t = d.items
    
21.     myPath = ThisWorkbook.Path & "\BOM"
    
22.     myName = Dir(myPath & "*.xls")
    
23.     Do While myName <> ""
    
24.         nm = Split(myName, ".")(0)
    
25.         If d.exists(nm) Then
    
26.         With GetObject(myPath & myName)
    
27.             Arr = .Sheets(1).Range("A1").CurrentRegion
    
28.             For i = 2 To UBound(Arr)
    
29.                 d1(Arr(i, 1)) = d1(Arr(i, 1)) + Arr(i, 4)
    
30.             Next
    
31.             .Close False
    
32.         End With
    
33.         End If
    
34.         myName = Dir
    
35.     Loop
    
36.     For i = 2 To UBound(Brr)
    
37.         If d1.exists(Brr(i, 1)) Then
    
38.             m = d1(Brr(i, 1))
    
39.             For j = 4 To UBound(Brr, 2)
    
40.                 For y = 2 To UBound(Arr1)
    
41.                     Brr(i, j) = Brr(i, j) + m * Arr1(y, j - 1)
    
42.                 Next
    
43.             Next
    
44.         End If
    
45.     Next
    
46.     [a1].CurrentRegion = Brr
    
47.     Application.ScreenUpdating = True
    
48. End Sub
    
49. 
    

复制代码

蓝桥玄霜

注意把BOM文件夹放在MPS文件夹里面作为子文件夹。
请见附件。

lsfeng

蓝桥玄霜 发表于 2013-9-13 20:19
注意把BOM文件夹放在MPS文件夹里面作为子文件夹。
请见附件。

版主，首先谢谢您的时间，我好好研究一下您的代码。

lsfeng

蓝桥玄霜 发表于 2013-9-13 20:16

蓝桥玄霜版主，首先感谢您花时间关注这个题目


遇到问题：

1）我测试几个数据，有计算错误，麻烦再查一下代码------应该是每个BOM的数据*MPS1中每周的数，再根据相同Part No 汇总，计算原理参照sumproduct 附件，谢谢！

2）当我在BOM文件夹增加 WHU456 的时候，如WHU456的 Part No 超出 ReqQty1 原来的范围（A:C），如用到新的Part No (355408988-355408994)附件黄色部分
     ReqQty1 表能否自动增加该部分（A15：C21），这样就不用担心BOM中新增部分到底有多少新的 Part No，还怕漏掉 Part No;
     对于MPS1，如需要增加Week14-Week18周，ReqQty1 能否在Q列以后自动增加，以匹配下标越界问题。不必再在ReqQty1表中手动增加Week14-Week18.(绿色部分Q1:U1）

谢谢！

蓝桥玄霜

请介绍一下Week1,Part No=355408975时，D2=？，是怎么计算的。
第2个问题已经解决。

1. Sub lqxs()
   
2.     Dim Arr, myPath$, myName$, Arr1, Myr&, d, cs$, d1, k, t
   
3.     Dim nm$, Brr, y&, m&, dz, d2
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set dz = CreateObject("Scripting.Dictionary")
   
7.     Set d2 = CreateObject("Scripting.Dictionary")
   
8.     Application.ScreenUpdating = False
   
9.     Sheet1.Activate
   
10.     cs = "MPS1"
    
11.     myPath = ThisWorkbook.Path & ""
    
12.     myName = cs & ".xls"
    
13.     With GetObject(myPath & myName)
    
14.         Arr1 = .Sheets(1).Range("A1").CurrentRegion
    
15.         For i = 2 To UBound(Arr1)
    
16.             d(Arr1(i, 1)) = d(Arr1(i, 1)) & i & ","
    
17.         Next
    
18.         For i = 3 To UBound(Arr1, 2)
    
19.             dz(Arr1(1, i)) = i
    
20.         Next
    
21.         .Close False
    
22.     End With
    
23.     k = d.keys: t = d.items
    
24.     myPath = ThisWorkbook.Path & "\BOM"
    
25.     myName = Dir(myPath & "*.xls")
    
26.     Do While myName <> ""
    
27.         nm = Split(myName, ".")(0)
    
28.         If d.exists(nm) Then
    
29.         With GetObject(myPath & myName)
    
30.             Arr = .Sheets(1).Range("A1").CurrentRegion
    
31.             For i = 2 To UBound(Arr)
    
32.                 d1(Arr(i, 1)) = d1(Arr(i, 1)) + Arr(i, 4)
    
33.                 x = Arr(i, 1) & "," & Arr(i, 2) & "," & Arr(i, 3)
    
34.                 d2(x) = ""
    
35.             Next
    
36.             .Close False
    
37.         End With
    
38.         End If
    
39.         myName = Dir
    
40.     Loop
    
41.     Cells.ClearContents
    
42.     [a1].Resize(1, 3) = Array("Part No", "Description", "MU")
    
43.     [a2].Resize(d2.Count) = Application.Transpose(d2.keys)
    
44.     Application.DisplayAlerts = False
    
45.     [a2].Resize(d2.Count).TextToColumns DataType:=xlDelimited, Comma:=True
    
46.     Range("d1").Resize(1, dz.Count) = dz.keys
    
47.     Brr = [a1].CurrentRegion
    
48.     For i = 2 To UBound(Brr)
    
49.         If d1.exists(Brr(i, 1)) Then
    
50.             m = d1(Brr(i, 1))
    
51.             For j = 4 To UBound(Brr, 2)
    
52.                 For y = 2 To UBound(Arr1)
    
53.                     Brr(i, j) = Brr(i, j) + m * Arr1(y, j - 1)
    
54.                 Next
    
55.             Next
    
56.         End If
    
57.     Next
    
58.     [a1].CurrentRegion = Brr
    
59.     Application.DisplayAlerts = True
    
60.     Application.ScreenUpdating = True
    
61. End Sub
    
62. 
    

复制代码

蓝桥玄霜

请见附件。