BOM循环计算问题，请有空的大神伸伸援手

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    d([f1].Value) = 300
l1:
    x = 0
    For j = 3 To UBound(arr)
        If d.exists(arr(j, 1)) Then
            d(arr(j, 2)) = d(arr(j, 1)) * arr(j, 3)
            arr(j, 1) = ""
            x = x + 1
        End If
    Next j
    If x > 0 Then GoTo l1
    d.Remove ([f1].Value)
    [e3].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    [f3].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
End Sub

liulang0808

附件内容供参考

liu-aguang

liulang0808 发表于 2021-5-12 22:55
Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion

老兄这段代码貌似有些问题:
1. 下面代码应该修改为累加代码:
d(arr(j, 2)) = d(arr(j, 1)) * arr(j, 3)
因为完全有可能出现这种情况: 如F001,它的不同子项中包含相同的零部件.
2. 这个宏对下面所述情况不能用:
以楼主的模拟要求为例,"父项"中S03以下的F001,如果有"中间件子项",则该子项不能包含有S03,否则代码无法计算其S03包含的子项.因为它的下面没有S03展开项,而上面作父项的S03已经在数组中置为空.
(好久没有接触VBA了,如果叙述有误,请略过)

liu-aguang

1. Dim arr, ar, d As Object
   
2. Sub BOM()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion
   
5.     ar = Application.Transpose(Application.Index(arr, , 1))
   
6.     Call subtab(Cells(1, "f"), Cells(1, "h"))
   
7.     [e3].Resize(UBound(arr, 1), 2) = ""
   
8.     [e3].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
   
9. End Sub
   
10. 
    
11. Sub subtab(key, r)
    
12.     For i = 3 To UBound(arr, 1)
    
13.         If arr(i, 1) <> key Then GoTo x
    
14.         If UBound(Filter(ar, arr(i, 2), 1)) = -1 Then
    
15.             d(arr(i, 2)) = d(arr(i, 2)) + r * arr(i, 3)
    
16.         Else
    
17.             d(arr(i, 2)) = d(arr(i, 2)) + r * arr(i, 3) '&#200;&#244;&#178;&#187;&#188;&#198;&#203;&#227;&#214;&#208;&#188;&#228;&#188;&#254;&#201;&#190;&#179;&#253;&#180;&#203;&#208;&#208;
    
18.             Call subtab(arr(i, 2), r * arr(i, 3))
    
19.         End If
    
20. x:    Next i
    
21. End Sub

复制代码

liu-aguang

1. Dim arr, ar, d As Object
   
2. Sub BOM()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a1].CurrentRegion
   
5.     ar = Application.Transpose(Application.Index(arr, , 1))
   
6.     Call subtab(Cells(1, "f"), Cells(1, "h"))
   
7.     [e3].Resize(UBound(arr, 1), 2) = ""
   
8.     [e3].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
   
9. End Sub
   
10. 
    
11. Sub subtab(key, r)
    
12.     For i = 3 To UBound(arr, 1)
    
13.         If arr(i, 1) <> key Then GoTo x
    
14.             d(arr(i, 2)) = d(arr(i, 2)) + r * arr(i, 3)
    
15.         If Not (UBound(Filter(ar, arr(i, 2), 1)) = -1) Then
    
16.             Call subtab(arr(i, 2), r * arr(i, 3))
    
17.         End If
    
18. x:    Next i
    
19. End Sub
    

复制代码

lzyxmj

一把小刀闯天下 发表于 2021-5-12 18:12
'目测了一下应该差不多，，，

Option Explicit

非常感谢大神，由于比较急用了另一个较笨的办法做的。你这个代码真的太精练了，我好好学习下，谢谢！！

lzyxmj

zpy2 发表于 2021-5-12 19:37
with recursive a (子,unit,total) as (values ('F001',1,300) union select 子项编码,子项用量*a.unit,子 ...

后续我尝试把数据迁移到sql server，谢谢帮助！

lzyxmj

zopey 发表于 2021-5-12 21:49
Sub dg(name)
If Not dic.exists(name) Then Exit Sub
For i = 1 To dic(name).childs.Count

非常感谢帮助，当时比较急用了另一办法。你这代码我好好学习下

lzyxmj

liulang0808 发表于 2021-5-12 22:55
Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion

卧槽，好强！！！我用复杂数据验证过，结论正确！代码简单，但思路好厉害

lzyxmj

liu-aguang 发表于 2021-5-13 22:12
老兄这段代码貌似有些问题:
1. 下面代码应该修改为累加代码:
d(arr(j, 2)) = d(arr(j, 1)) * arr(j, 3) ...

把d(arr(j, 2)) = d(arr(j, 1)) * arr(j, 3)改成d(arr(j, 2)) = d(arr(j, 2)) + d(arr(j, 1)) * arr(j, 3)就行了，我验证过是正确的