将成品BOM表中的半成品分拆至料件级（最底层）

ctkuk

公司产品的BOM表中有些是包含半成品的，为方便操作/计算，希望将BOM表中半成品分拆至料件级。本人不懂VBA，也试图在论坛中找相关的帖子来参考，但没找到类似的。还请大家帮帮忙，多谢！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a3:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Left(arr(i, 1), 1) = "半" Then
    
11.         If Not d.exists(arr(i, 1)) Then
    
12.           Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
13.         End If
    
14.         d(arr(i, 1))(i) = ""
    
15.       End If
    
16.     Next
    
17.     ReDim brr(1 To 1000, 1 To 4)
    
18.     m = 0
    
19.     For i = 1 To UBound(arr)
    
20.       If Left(arr(i, 1), 1) <> "半" Then
    
21.         If Not d.exists(arr(i, 2)) Then
    
22.           m = m + 1
    
23.           brr(m, 1) = arr(i, 1)
    
24.           brr(m, 2) = arr(i, 2)
    
25.           brr(m, 3) = arr(i, 2)
    
26.           brr(m, 4) = arr(i, 3)
    
27.         Else
    
28.           For Each bb In d(arr(i, 2)).keys
    
29.             m = m + 1
    
30.             brr(m, 1) = arr(i, 1)
    
31.             brr(m, 2) = arr(i, 2)
    
32.             brr(m, 3) = arr(bb, 2)
    
33.             brr(m, 4) = arr(i, 3) * arr(bb, 3)
    
34.           Next
    
35.         End If
    
36.       End If
    
37.     Next
    
38.     .Range("e3").Resize(m, UBound(brr, 2)) = brr
    
39.   End With
    
40. End Sub
    
41. 
    

复制代码

chxw68

详见附件。

ctkuk

chxw68 发表于 2018-9-17 15:15
详见附件。

非常感谢！试完之后，发现表2的成品名称不是自动生成的，还请帮忙再看看，谢谢！

很不好意思，是我的电脑有点问题，再试过，一切正常，感谢感谢！

不知道为什么

也凑个热闹，如图

不知道为什么

               

chxw68

ctkuk 发表于 2018-9-17 15:41
非常感谢！试完之后，发现表2的成品名称不是自动生成的，还请帮忙再看看，谢谢！

你发个图片说明一下，没看明白。

ctkuk

chxw68 发表于 2018-9-17 15:54
你发个图片说明一下，没看明白。

实在不好意思，我的电脑有点问题，再试过之后，一切正常，感谢感谢！

wbjjzhu

你的问题与我遇到的类似，可以参考以下帖子：
http://club.excelhome.net/thread-1432113-1-2.html