BOM材料成本核算

chengshanming

1. Sub 物料心_Click()
   
2. Application.ScreenUpdating = False
   
3. Dim ar, i&, m&, s, d(1 To 10), br, cr, dr, j&, y
   
4.     For i = 1 To UBound(d)
   
5.      Set d(i) = CreateObject("Scripting.Dictionary")
   
6.      Next
   
7. With Sheet23
   
8. ar = .UsedRange.Value '当前工作表单数据为数组
   
9. br = .Range(.Cells(2, 1), .Cells(UBound(ar, 1), 1))
   
10. For Each X In br '取BOM的最大层级
    
11.     If X > y Then y = X
    
12. Next X
    
13. For n = y To 0 Step -1  'n为所有成品中的最大层级
    
14. ar = .UsedRange.Value '当前工作表单数据为数组
    
15. ReDim cr(0 To 1000, 1 To 2) '最近阶半成品提取
    
16. For i = 2 To UBound(ar, 1)
    
17. If ar(i, 1) = 0 Then
    
18. Top = ar(i, 2)
    
19. cr(ar(i, 1) + 1, 1) = Top
    
20. Else
    
21. cr(ar(i, 1) + 1, 1) = ar(i, 2)
    
22. cr(ar(i, 1), 2) = Top
    
23. End If
    
24. d(1 + n)(ar(i, 1) & cr(ar(i, 1), 1) & " | " & cr(ar(i, 1), 2)) = d(1 + n)(ar(i, 1) & cr(ar(i, 1), 1) & " | " & cr(ar(i, 1), 2)) + ar(i, 7) * ar(i, 5) * (1 + ar(i, 6))
    
25. .Cells(i, 4) = cr(ar(i, 1), 1) & " | " & cr(ar(i, 1), 2)
    
26. Next
    
27. ar = .UsedRange.Value '当前工作表单数据为数组
    
28. For i = 2 To UBound(ar, 1)
    
29. If .Cells(i, 1) < .Cells(i + 1, 1) Then
    
30. .Cells(i, 7) = d(1 + n)(.Cells(i, 1) + 1 & .Cells(i + 1, 4))
    
31. End If
    
32. Next
    
33. Next n
    
34. End With
    
35. Application.ScreenUpdating = True
    
36. MsgBox "ok"
    
37. End Sub
    
38. 
    

复制代码

chengshanming

代码更新，计算更准确！

1. Private Sub 材料_Click()
   
2. 'Application.ScreenUpdating = False
   
3. Dim ar, i&, cr, dr
   
4. Dim cl%, qh(1000) '层级可自行修改
   
5. 
   
6. With Sheet1
   
7. Sheet1.Range(Sheet1.Cells(2, 7), Sheet1.Cells(Sheet1.Range("a" & Rows.Count).End(xlUp).Row, Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column)) = Empty
   
8. ar = .Range("a1").CurrentRegion.Resize(, 7)
   
9. For i = UBound(ar, 1) To 2 Step -1
   
10. If ar(i, 1) = cl - 1 Then
    
11. ar(i, 6) = qh(cl)
    
12. qh(cl) = 0
    
13. End If
    
14. ar(i, 7) = ar(i, 4) * (1 + ar(i, 5)) * ar(i, 6)
    
15. cl = ar(i, 1)
    
16. qh(cl) = qh(cl) + ar(i, 4) * (1 + ar(i, 5)) * ar(i, 6)
    
17. Next
    
18. 
    
19. Sheet1.Range("a1").Resize(UBound(ar, 1), 7) = ar
    
20. ar = .Range("a1").CurrentRegion.Resize(, 8)
    
21. ReDim cr(0 To 1000, 1 To 2) '最近阶半成品提取
    
22. For i = 2 To UBound(ar, 1)
    
23. If ar(i, 1) = 0 Then
    
24. Top = ar(i, 2)
    
25. cr(ar(i, 1) + 1, 1) = Top
    
26. cr(ar(i, 1), 1) = "0阶"
    
27. cr(ar(i, 1), 2) = Top
    
28. Else
    
29. cr(ar(i, 1) + 1, 1) = ar(i, 2)
    
30. cr(ar(i, 1), 2) = Top
    
31. End If
    
32. .Cells(i, 8) = cr(ar(i, 1), 1) & " | " & cr(ar(i, 1), 2)
    
33. Next
    
34. With Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(Sheet1.Range("a" & Rows.Count).End(xlUp).Row, Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column))
    
35.         .Font.Size = 9
    
36.         .Font.Name = "新細明體"
    
37.         .HorizontalAlignment = xlCenter
    
38.         .VerticalAlignment = xlBottom
    
39.     End With
    
40. End With
    
41. 'Application.ScreenUpdating = True
    
42. MsgBox "材料成本计算完毕" & Chr(10) & "请查核准确性!", vbInformation, "提醒"
    
43. End Sub

复制代码

SHCHFUWU

0
楼主辛苦  谢谢分享

沈默00

谢谢分享