BOM智能计算

yiyiyicz

关注篮版的代码

“多层与单层弄在一起，原理上行的通吗”
这是肯定的，单层BOM是多层BOM的特例。能计算多层BOM，肯定能计算单层BOM。在实际应用中，流程行业一般是单层，离散制造几乎都是多层BOM
楼主的标题要求“智能计算”，怎么个智能法？

蓝桥玄霜

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

复制代码

lsfeng

蓝桥玄霜 发表于 2014-7-11 09:24

蓝桥老师，计算结果搞反了，或者我没有表达清楚（见附件）：

比如 MPS 里面 有名称为 109（2）的 BOM，但 BOM文件夹并没有这个 BOM， 计算后就显示“缺少 109（2）”的BOM
但如果BOM文件夹集合如果包含所有 MPS 表中显示的型号，则提示“计算完毕”

现在程序显示了 MPS与  BOM文件夹集合 的差异。不是要的答案。

要的答案是：

  A) BOM文件夹是一个BOM“仓库”，包含所有BOM，MPS是计算其中的部分BOM，如果MPS出现一个新的型号，忘记在BOM那个“仓库”里增加该BOM，程序能够发现这个错误。而不是比较  MPS与 BOM仓库的差异。 只要MPS中的型号属于BOM集合，就显示“计算完毕”；只要MPS中的型号有超出 BOM集合的范围，就显示缺少那些 MPS中在BOM“仓库”里面找不到对应型号的名称;

  B)  如果MPS没有，BOM里有，就不必显示

这个主要是为了显示BOM漏了计算某个新增型号做一个提醒

谢谢！

lsfeng

lsfeng 发表于 2014-7-11 12:51
蓝桥老师，计算结果搞反了，或者我没有表达清楚（见附件）：

比如 MPS 里面 有名称为 109（2）的 BO ...

哪位高手能帮忙改改吗？谢谢！

lsfeng

蓝桥玄霜 发表于 2014-7-11 09:24

蓝桥版主，很希望您在这展示"filter"用法得到下面要求的准确结果，谢谢！

lsfeng

lsfeng 发表于 2014-7-11 12:51
蓝桥老师，计算结果搞反了，或者我没有表达清楚（见附件）：

比如 MPS 里面 有名称为 109（2）的 BO ...

有哪位老师读得懂蓝桥老师的代码，并愿意帮忙看看能否在蓝老师的基础上，改一改达到 32楼的要求，谢谢!

lsfeng

蓝桥玄霜 发表于 2014-7-11 09:24

蓝桥老师，我看这个问题只有您能解决，我问过很多人，包括教Excel的老师都找不到答案。我自己弄了很久还是没办法搞妥。

您这个程序能找出 MPS与BOM总清单的差异，并做提示。这样那个提示会显示太多BOM名字

实际需要找出：
1）MPS里面有，在BOM文件夹里面找不到对应BOM的，用来计算物料需求。因为如果有漏BOM，计算结果很难发现，漏了一个或几个BOM。

2）如果MPS里面没有，而BOM有，则不要显示。否则那个提示会太长，起不到提示的作用。十几种BOM可能有100个，MPS中需要计算的可能只有10个。那样提示就会变成90个。

如果您有空帮忙看看，万分感谢！
我现在的做法是： 提取BOM文件夹所有名称，与MPS用Vlookup对比。方法太土不是很方便。

蓝桥玄霜

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

复制代码

lsfeng

蓝桥玄霜 发表于 2014-7-25 09:48

蓝桥老师，非常感谢您的帮助！看到您蓝桥BOM之后，震撼了！我开始了学习Excel,也发动周边的人学习，已经买了6本ExcelHome出版的书，但水平有限，看得很慢，很多东西不懂。这是早上最好的礼物！再次感谢！

977809708

版主高手中的高手