月计划拆分每日物料需求--谢谢！

wzcnpucheng

ykcbf1100

物料需求拆分。

wzcnpucheng

ykcbf1100 发表于 2023-2-21 15:23
物料需求拆分。

感谢出手相助，谢谢！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("BOM")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         arr = .Range("a2:i" & r)
   
10.         For i = 1 To UBound(arr)
    
11.             If Not d1.exists(arr(i, 1)) Then
    
12.                 Set d1(arr(i, 1)) = CreateObject("scripting.dictionary")
    
13.             End If
    
14.             d1(arr(i, 1))(arr(i, 3)) = arr(i, 9)
    
15.         Next
    
16.     End With
    
17.     With Worksheets("生产计划")
    
18.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
20.         arr = .Range("a4").Resize(r - 3, c)
    
21.     End With
    
22.     ls = UBound(arr, 2) - 10 + 6
    
23.     For i = 2 To UBound(arr)
    
24.         If d1.exists(arr(i, 1)) Then
    
25.             For Each bb In d1(arr(i, 1)).keys
    
26.                 If Not d.exists(bb) Then
    
27.                     ReDim brr(1 To ls)
    
28.                     brr(1) = bb
    
29.                 Else
    
30.                     brr = d(bb)
    
31.                 End If
    
32.                 For j = 11 To UBound(arr, 2)
    
33.                     brr(j - 4) = brr(j - 4) + arr(i, j) * d1(arr(i, 1))(bb)
    
34.                 Next
    
35.                 d(bb) = brr
    
36.             Next
    
37.         End If
    
38.     Next
    
39.     With Worksheets("物料需求")
    
40.         .Cells.Clear
    
41.         .Range("a3:f3") = Array("物料代号", "规格", "单位", "其他信息", "描述", "备注")
    
42.         For j = 11 To UBound(arr, 2)
    
43.             .Cells(3, j - 4) = arr(1, j)
    
44.         Next
    
45.         .Cells(3, 7).Resize(1, UBound(arr, 2) - 10).NumberFormatLocal = "m月d日"
    
46.         .Range("a4").Resize(d.Count, ls) = Application.Transpose(Application.Transpose(d.items))
    
47.         With .Range("a3").Resize(1 + d.Count, ls)
    
48.             .Borders.LineStyle = xlContinuous
    
49.             With .Font
    
50.                 .Name = "微软雅黑"
    
51.                 .Size = 11
    
52.             End With
    
53.             .HorizontalAlignment = xlCenter
    
54.             .VerticalAlignment = xlCenter
    
55.         End With
    
56.     End With
    
57. End Sub
    

复制代码

chxw68

只是针对附件写的！不保证附件变了后能正常使用。

wzcnpucheng

chxw68 发表于 2023-2-21 15:36
只是针对附件写的！不保证附件变了后能正常使用。

你好，谢谢你提供的帮助。物料拆分表中有个问题能帮忙再优化下么？例如A产品它的BOM表较为复杂，同一物料它可能存在不同的组件中，而我想直接复制BOM，人为去整理易出错。你发的版本支持不同产品同一物料需求相加，而同一产品同一物料目前不能相加

chxw68

wzcnpucheng 发表于 2023-2-22 10:01
你好，谢谢你提供的帮助。物料拆分表中有个问题能帮忙再优化下么？例如A产品它的BOM表较为复杂，同一物料 ...

应该能相加的，你再试试，如果不行你把文件发上来。

wzcnpucheng

chxw68 发表于 2023-2-22 10:28
应该能相加的，你再试试，如果不行你把文件发上来。

求助

chxw68

修改好了。

wzcnpucheng

chxw68 发表于 2023-2-22 11:24
修改好了。

可以了，谢谢！