父件子件关系的BOM表格计算方法之一（蓝桥方法）

wengen

重上传一份，请老大

特请老大优化一下：金额1　金额2　后面还有　金额3　金额4....,并按　111、110、101...112、113　如上面的排序，特请老大优化一下
    汇总表格式　金额1　金额1号　金额2　金额2号　后面还有　金额3　金额3号....,
    x = Range("M2").Value '日期
      X1 = Range("M3").Value日期
       y = Range("P3").Value
       YY = Year(x) & Format(Month(x), "00") & "' and format(消费日期,'yyyymm') <= '" & Year(X1) & Format(Month(X1), "00")
  Dim arr
        
      Set cnn = CreateObject("adodb.connection")
   cnn.Open "provider=microsoft.jet.oledb.4.0;data source =" & ThisWorkbook.path & "\系统数据库.mdb" '员工11金额11产品
     SQL111 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 111 & "' HAVING 金额1号 "
     SQL110 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 110 & "' HAVING 金额1号 "
     SQL101 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 101 & "' HAVING 金额1号 "
     SQL102 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 102 & "' HAVING 金额1号 "
     SQL103 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 103 & "' HAVING 金额1号 "
     
     SQL104 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 104 & "' HAVING 金额1号 "
     SQL105 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 105 & "' HAVING 金额1号 "
     SQL106 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 106 & "' HAVING 金额1号 "
     SQL107 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 107 & "' HAVING 金额1号 "
     SQL109 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 109 & "' HAVING 金额1号 "
     SQL112 = "SELECT sum(金额1) as 金额1 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额1号　like '" & 112 & "' HAVING 金额1号 "
     
     Set rs = New ADODB.Recordset
      SQL = "select a.金额1,b.金额1,c.金额1,d.金额1,e.金额1,f.金额1,g.金额1,h.金额1,i.金额1,j.金额1,k.金额1 from (" & SQL111 & ") a,(" & SQL110 & ") b,(" & SQL101 & ") c,(" & SQL102 & ") d,(" & SQL103 & ") e,(" & SQL104 & ") f ,(" & SQL105 & ") g,(" & SQL106 & ") h,(" & SQL107 & ") i,(" & SQL109 & ") j,(" & SQL112 & ") k "
      rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
      arr = cnn.Execute(SQL).GetRows
      Range("D6").Resize(UBound(arr) + 1, UBound(arr, 2) + 1) = arr '行转列保存
      
      Set cnn = CreateObject("adodb.connection")  '
   cnn.Open "provider=microsoft.jet.oledb.4.0;data source =" & ThisWorkbook.path & "\系统数据库.mdb" '
     SQL111 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 111 & "' HAVING 金额2号 "
     SQL110 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 110 & "' HAVING 金额2号 "
     SQL101 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 101 & "' HAVING 金额2号 "
     SQL102 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 102 & "' HAVING 金额2号 "
     SQL103 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 103 & "' HAVING 金额2号 "
     
     SQL104 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 104 & "' HAVING 金额2号 "
     SQL105 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 105 & "' HAVING 金额2号 "
     SQL106 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 106 & "' HAVING 金额2号 "
     SQL107 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 107 & "' HAVING 金额2号 "
     SQL109 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 109 & "' HAVING 金额2号 "
     SQL110 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 110 & "' HAVING 金额2号 "
     SQL112 = "SELECT sum(金额2) as 金额2 FROM 营业额  where format(消费日期,'yyyyMM') >= '" & YY & "' and 金额2号 like '" & 112 & "' HAVING 金额2号 "
      
     Set rs = New ADODB.Recordset
      SQL = "select a.金额2,b.金额2,c.金额2,d.金额2,e.金额2,f.金额2,g.金额2,h.金额2,i.金额2,j.金额2,k.金额2 from (" & SQL111 & ") a,(" & SQL110 & ") b,(" & SQL101 & ") c,(" & SQL102 & ") d,(" & SQL103 & ") e,(" & SQL104 & ") f ,(" & SQL105 & ") g,(" & SQL106 & ") h,(" & SQL107 & ") i,(" & SQL109 & ") j,(" & SQL112 & ") k "
      rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
      arr = cnn.Execute(SQL).GetRows
      Range("E6").Resize(UBound(arr) + 1, UBound(arr, 2) + 1) = arr '行转列保存

特请老大优化一下：金额1　金额2　后面还有　金额3　金额4....,并按　111、110、101...112、113 如上面的排序，特请老大优化一下

雄鹰2013

Sub bom计算3() '雄鹰2018.5.20
  Sheet1.Activate
  Dim arr, brr(), d As Object
  Dim a As Byte, b As Byte, x As Double
  Set d = CreateObject("scripting.dictionary")
  t = Timer
arr = Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr) - 1, 1 To 3)
For j = 5 To 7
     i = UBound(arr)
     For i = i To 2 Step -1
         Do
           a = Len(arr(i, 1)) '本行
           b = Len(arr(i - 1, 1)) '上一行
           If x <> 0 Then 'x表示下一级的工时合计
              If arr(i, 3) <> "" Then
                 s = arr(i, 3) * (arr(i, j) + x)
                 x = 0
              End If
           Else
              s = arr(i, 3) * arr(i, j)
           End If
           d(a) = d(a) + s
           If s <> 0 Then
              brr(i - 1, j - 4) = s
              If a = 1 Then ss = ss + s
           End If
           If a <> b Then
              If a > b Then
                 If a <> 1 Then x = d(a) '将本级累计的工时赋值给x
              Else
                 If a <> 1 Then '如果下级大于上级
                    d(a + 1) = 0
                 End If
              End If
           End If
           i = i - 1
           If arr(i, 1) = "父级" Then Exit For
         Loop Until b = 1
         i = i + 1: d.RemoveAll
    Next i
    brr(i - 1, j - 4) = ss: ss = 0
Next j
[n2].Resize(UBound(brr), 3) = brr
MsgBox Format(Timer - t, "0.00秒")
End Sub

雄鹰2013

运行速度是原代码的4到5倍

dreamcloud

早看到这个帖子就好了。自己需要按照BOM表和库存算缺料，因为最多有六介子料，琢磨了个把星期。还好问题解决了。思路可供大家借鉴。
1、根据BOM表完全展开逐行判断
2、父料的缺料直接根据库存和需求算父料的缺料状况，若父料不足，则确认不足的数量
3、子料的缺料先查找上一阶的父料缺料数量，若父料不缺则此子料不缺，若父料不足则以不足的数量乘以子料的用量，再减去库存，判断出子料的状况。

448478825

蓝桥老师你好！请问附件在哪里？看到附件有助于理解程序的。

破面online

拜读蓝版作品，学习ing

fsr131

初级小白，我先收藏了，慢慢学习