一个关于BOM层级计算的问题

potatofan

大家好，现在还是个小白，没有系统的学习，只能从改代码开始。
目前想从一个多层的BOM表中单独计算一个层级的
如“汇总式”表里的展开级别是“2”层的挑出来单独计算成本
现在想做的就是把二层挑出来，然后把他的下阶“3和4”层挑出来作为2层子件的成本
请各位大神指导，谢谢帮助。

yjh_27

站内搜 BOM

lsdongjh

做个最终效果表，把计算关系描述一下

potatofan

lsdongjh 发表于 2018-7-11 12:45
做个最终效果表，把计算关系描述一下

我描述与更改了表格，谢谢帮忙。

potatofan

yjh_27 发表于 2018-7-11 11:52
站内搜 BOM

不知道哪个跟我的问题类似？请指引，谢谢指导

yjh_27

potatofan 发表于 2018-7-11 14:16
不知道哪个跟我的问题类似？请指引，谢谢指导

4L附件能多说几句吗？哪几个工作表是原始数据，哪个工作表是想要的结果，哪个是说明计算过程用的

BOM 大纲排序-自定义函数
http://club.excelhome.net/thread-1175717-1-1.html
(出处: ExcelHome技术论坛)

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, pos, brr, i, j, k, a, b, n, crr, sum
  With Sheets("报价编码")
    arr = .Range("a2:j" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
  End With
  brr = Sheets("汇总式").[a2:c2]
  ReDim crr(1 To UBound(arr, 1), 1 To UBound(arr, 2)) As String
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 3) = brr(1, 1) Then pos = j: Exit For
    Next
    If j = UBound(arr, 1) Then Exit For
    For j = pos To UBound(arr, 1) - 1
      If arr(j, 3) <> arr(j + 1, 3) Then
        For k = pos To j
          If arr(k, 5) = brr(1, 2) Then
            For a = k + 1 To j
              If Len(arr(a, 2)) - Len(arr(k, 2)) <= brr(1, 3) Then
                n = n + 1: sum = sum + arr(a, UBound(arr, 2))
                For b = 2 To UBound(arr, 2): crr(n, b - 1) = arr(a, b): Next
              End If
              If Len(arr(a + 1, 2)) <= Len(arr(k + 1, 2)) Then Exit For
            Next
            k = j: Exit For
          End If
        Next
        i = j: Exit For
      End If
  Next j, i
  crr(n + 1, UBound(crr, 2) - 2) = "合计"
  crr(n + 1, UBound(crr, 2) - 1) = sum
  With Sheets("下阶成本").[a2]
    .Resize(Rows.Count - 1, UBound(crr, 2)).ClearContents
    .Resize(n + 1, UBound(crr, 2) - 1) = crr
  End With
End Sub

标准成本库.rar (35.37 KB, 下载次数: 37)

2018-7-11 15:32 上传

点击文件名下载附件

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub 多阶式()
   
4.     Dim SH As Worksheet, strShName As String
   
5.     Dim lngRows As Long, lngRow As Long
   
6.     Dim arrCondition As Variant, strCondition As String, strLevel As String
   
7.     Dim Conn As Object, Rst As Object, strPath As String
   
8.     Dim strConn As String, strSQL As String
   
9.     Dim rgResultA As Range, rgResultB As Range
   
10.    
    
11.     ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
12.     strShName = "报价编码"
    
13.     Set SH = Sheets(strShName)
    
14.     lngRows = SH.Range("A" & Rows.Count).End(xlUp).Row
    
15.     If lngRows < 2 Then Exit Sub '条件区域无值
    
16.    
    
17.     '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
18.     Application.ScreenUpdating = False
    
19.     Application.Cursor = xlWait
    
20.    
    
21.     '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
22.     arrCondition = SH.Range("A1:A" & lngRows)
    
23.     '组装 母件编码 条件
    
24.     For lngRow = LBound(arrCondition) + 1 To UBound(arrCondition)
    
25.         strCondition = strCondition & "," & Chr(34) & arrCondition(lngRow, 1) & Chr(34)
    
26.     Next
    
27.     strCondition = Mid(strCondition, 2) '母件编码
    
28.    
    
29.     '''''''''''''''''''''''''''''''''''''''''''''''''''''
    
30.     strShName = "汇总式"
    
31.     Set SH = Sheets(strShName)
    
32.     lngRows = SH.Range("A" & Rows.Count).End(xlUp).Row
    
33.     If lngRows < 2 Then lngRows = 2
    
34.     SH.Range("A2:C" & lngRows).ClearContents ' 清除结果区域
    
35.     Set rgResultA = SH.Range("A2")
    
36.    
    
37.     strShName = "下阶成本"
    
38.     Set SH = Sheets(strShName)
    
39.     lngRows = SH.Range("A" & Rows.Count).End(xlUp).Row
    
40.     If lngRows < 2 Then lngRows = 2
    
41.     SH.Range("A2:I" & lngRows).ClearContents ' 清除结果区域
    
42.     Set rgResultB = SH.Range("A2")
    
43.    
    
44.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
45.     Set Conn = CreateObject("ADODB.Connection")
    
46.     Set Rst = CreateObject("ADODB.Recordset")
    
47.     strPath = ThisWorkbook.Path & "\汇总式.xls"
    
48.     Select Case Application.Version * 1
    
49.         Case Is <= 11
    
50.             strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
    
51.         Case Is >= 12
    
52.             strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
53.     End Select
    
54.     Conn.Open strConn
    
55. 
    
56.     ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
57.     strLevel = Chr(34) & "..2" & Chr(34) '展开级别
    
58. 
    
59.     strSQL = "SELECT 母件编码,子件编码,展开级别 " & _
    
60.              "FROM [1$] " & _
    
61.              "WHERE 展开级别 In (" & strLevel & ") AND 母件编码 In (" & strCondition & ")" & _
    
62.              "GROUP BY 母件编码,子件编码,展开级别 " & _
    
63.              "ORDER BY 母件编码,子件编码,展开级别;"
    
64.             
    
65.     Rst.Open strSQL, Conn, 3, 1
    
66.     rgResultA.CopyFromRecordset Rst
    
67.    
    
68.     ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
69.     strLevel = Chr(34) & "...3" & Chr(34) '展开级别
    
70.     strLevel = strLevel & "," & Chr(34) & "....4" & Chr(34) '展开级别
    
71. 
    
72.     strSQL = "SELECT 展开级别,母件编码,母件描述,子件编码,料品描述,单位名称,标准用量,单价,金额 " & _
    
73.              "FROM [1$] " & _
    
74.              "WHERE 展开级别 In (" & strLevel & ") AND 母件编码 In (" & strCondition & ")" & _
    
75.              "ORDER BY 展开级别 DESC,母件编码,子件编码;"
    
76.             
    
77.     If Rst.State = 1 Then Rst.Close
    
78.     Rst.Open strSQL, Conn, 3, 1
    
79.     rgResultB.CopyFromRecordset Rst
    
80.    
    
81.     Set Rst = Nothing
    
82.     Set Conn = Nothing
    
83. 
    
84.     MsgBox "OK"
    
85. 
    
86.     '''''''''''''''''''''''''''''''''''''''''''''''''''
    
87.     Application.ScreenUpdating = True
    
88.     Application.Cursor = xlDefault
    
89. End Sub
    
90. 
    
91. 
    
92. 
    
93. 
    
94. 
    

复制代码

840205910

z这个BOM表好像不正确，上下级关系没有体现。同样是四级，哪个三级管，

potatofan

lsdongjh 发表于 2018-7-11 15:38

你好，我按你写的代码运行显示下标越界是啥情况呀？