Bom嵌套展开到末级（计算材料用）

gjj136138139 · 发表于 2024-1-2 15:19

注意嵌套层级，要的是末级材料。就是查找材料时，它没有子级。是不是得先把材料的haschild先生成，再循环到haschild=false时终止。

cidanji · 发表于 2024-1-2 15:34

gjj136138139 发表于 2024-1-2 15:15
加一层级，数就不对。得重新再生成一个字典。

什么意思
是不是你加的编码不统一原因

x-xx-xx · 发表于 2024-1-2 15:41

没问题
C003
c003

sosomc · 发表于 2024-1-2 17:49

https://club.excelhome.net/thread-1355098-1-1.html

x-xx-xx · 发表于 2024-1-2 21:38

递归很不擅长,感觉每次都是瞎写一通靠运气,都以为要写不出来了,不知道怎么结果好像对了
$Q2A$$JNDZ9}A~COT{_2O(1P.png$

20240102_212419.rar (36.26 KB, 下载次数: 4)

opiona · 发表于 2024-1-2 22:21

本帖最后由 opiona 于 2024-1-2 23:24 编辑

递归解决BOM无限嵌套的问题
https://club.excelhome.net/thread-1445694-1-1.html

如果是展开则需求数量=1

QQ14885553.rar (28 KB, 下载次数: 18)

核心代码: 不限制层级

'*********************************
'******* 北极狐工作室出品 ******
'******* QQ：14885553 ******
'*********************************
Option Explicit '//强制声明变量
Dim BRX, ZBC, ZBD, PRX, ZPD
Dim INTX As Long
Dim StrPA As String
Sub A_BOM拆解()
Dim Path As String
Dim WB As Workbook
Dim SHX, SHD, SHN, SHT As Worksheet
Dim I, X, ICOL, IROW, MAXROW, MAXCOL As Long
Dim ARX, CRX, ERX, ZCC
Rem 禁止系统刷屏?触发其他事件等
'On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Application.EnableEvents = False '//禁止触发其他事件
Application.StatusBar = True '关闭系统状态条
Rem Application.Calculation = xlManual '//xlCalculationManual 用户请求时进行计算
Dim T
T = Timer '//开始时间
Rem 获取BOM文件或者BOM的全部数据到全局变量: BRX
Set SHD = Worksheets("BOM")
SHD.AutoFilterMode = False '//取消筛选
MAXCOL = SHD.Range("IT1").End(xlToLeft).Column
Set ZBC = CreateObject("Scripting.Dictionary")
For ICOL = 1 To MAXCOL
ZBC(SHD.Cells(1, ICOL).Value) = ICOL
Next
MAXROW = SHD.Range(SHD.Cells(SHD.Rows.Count, ZBC("商品编码")).Address).End(3).Row
BRX = SHD.Range("A1:" & SHD.Cells(MAXROW, MAXCOL).Address).Value
Rem 判断ID是否存在下一层
Set ZBD = CreateObject("Scripting.Dictionary")
For X = 2 To UBound(BRX, 1)
If ZBD.EXISTS("" & BRX(X, ZBC("商品编码"))) = False Then
ZBD("" & BRX(X, ZBC("商品编码"))) = X
Else
ZBD("" & BRX(X, ZBC("商品编码"))) = ZBD("" & BRX(X, ZBC("商品编码"))) & "," & X
End If
Next
ERX = ZBD.KEYS
Rem 初始化公共变量保存结果 PRX
INTX = 0
ReDim PRX(1 To 3, 1 To 1) '//输出结果数组，需转置
Set ZPD = CreateObject("Scripting.Dictionary") '//记录那些ID已经存在就直接相加
Rem 开始了!
For X = 0 To UBound(ERX)
Rem 调用函数父件+数量
StrPA = ERX(X)
Call GETBOM(ERX(X), 1)
Next
Rem 最终结果转置
ARX = TransposeTWO(PRX)
Rem 粘贴数据
Set SHT = Worksheets("结果表")
SHT.Select
SHT.Rows("2:" & SHT.Rows.Count).ClearContents
SHT.Range("A2").Resize(UBound(ARX, 1), UBound(ARX, 2)) = ARX
Rem Application.Calculation = xlAutomatic '//xlCalculationAutomaticExcel 控制重新计算。
Application.StatusBar = False '恢复系统状态条
Application.EnableEvents = True '// '//恢复触发其他事件
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
MsgBox "一共用时：" & Format(Timer - T, "#0.0000") & " 秒", , "北极狐QQ：14885553" '//提示所用时间
End Sub
Sub GETBOM(ByVal StrID As String, ByVal DOU As Double)
Dim X, IROW As Long
Dim StrB As String
Dim FRX
Rem BOM表父件中查找此ID
FRX = Split(ZBD(StrID), ",")
For X = 0 To UBound(FRX)
If ZBD.EXISTS("" & BRX(Val(FRX(X)), ZBC("材料编码"))) Then
Rem 如果还有下一层，则：万恶的递归开始了
Call GETBOM("" & BRX(Val(FRX(X)), ZBC("材料编码")), Val(BRX(Val(FRX(X)), ZBC("标准用量"))) * DOU)
Else
Rem 判断结果数组PRX中是否存在此ID
StrB = "" & StrPA & BRX(Val(FRX(X)), ZBC("材料编码"))
If ZPD(StrB) Then
Else
Rem 结果数组中不存在此ID，则增加一个ID
INTX = INTX + 1
ZPD(StrB) = INTX
ReDim Preserve PRX(1 To UBound(PRX, 1), 1 To INTX)
PRX(1, INTX) = StrPA
PRX(2, INTX) = "" & BRX(Val(FRX(X)), ZBC("材料编码"))
End If
Rem 用量
IROW = ZPD(StrB)
PRX(3, IROW) = Val(PRX(3, IROW)) + Val(BRX(Val(FRX(X)), ZBC("标准用量"))) * DOU '//百分比要除：100，用量则不需要
End If
Next
End Sub

复制代码

wbjjzhu · 发表于 2024-1-2 22:33

感兴趣的问题，关注中。。。。

zpy2 · 发表于 2024-1-3 09:32

本帖最后由 zpy2 于 2024-1-3 09:33 编辑

gjj136138139 发表于 2024-1-2 15:01
数据库的话，比较麻烦，好多人电脑上都没法装。我希望是vba写出来的代码直接在office环境下解决问题。vba ...

https://club.excelhome.net/thread-1613315-1-1.html?_dsign=52c4ed06

select * from bom需求计算;with recursive under_alice(子,单耗,需求) as (select 子,单耗,需求 from bom需求计算 where 需求 not like "" union select x.子,x.单耗,x.单耗*under_alice.需求 from bom需求计算 x join under_alice on x.父 =under_alice.子)select 子,sum(需求) from under_alice group by 子;

在线sql,web版sqlite支持递归查询

gjj136138139 · 发表于 2024-1-3 21:07

cidanji 发表于 2024-1-2 10:36

d(x)(z) = d(x)(z) + d(x)(y) * d(y)(z) '这一句太牛了，新增了x和z对应的key（字典）--即在d(x)中增加了key为z，并带上了item值，为父和子的用量相乘--表示成x和z之间的用料 d(x).Remove y: ky = 1 '这是个做标记，好退出递归循环？因为后面有If ky = 0 Then Exit Sub，不是太理解这个ky。

gjj136138139 · 发表于 2024-1-3 21:30

x-xx-xx 发表于 2024-1-2 21:38
递归很不擅长,感觉每次都是瞎写一通靠运气,都以为要写不出来了,不知道怎么结果好像对了

哥们儿，我虽然不太会写代码，但是我知道代码不能这么写，你要改变一下儿，这么写代码，写的人会累死，看的也会累死的。写代码的目的是减少工作量，说白了，模块的目的就自动处理重复工作，就是用好循环来解决问题。怎么把父的换算率通过sub带到下一层去。还没写好，但至少有点递归的样子。我的想法是用redim preserve动态数组来存储结果。

Dim n As Long
Dim Brr()
Sub main()
Dim BomArr
BomArr = Sheet1.[A2:D16]
For i = LBound(BomArr) To UBound(BomArr)
Spread i, BomArr(i, 1), BomArr, BomArr(i, 4), BomArr(i, 3), ""
Next i
Stop
Brr = Application.Transpose(Brr)
Sheets("tmp").[a2].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub
Sub Spread(ByVal Index As Long, ByVal parentStr As String, ByVal Arr, ByVal isEnd As String, ByVal k As Long, ByVal varStr As String)
'Dim iStart As Long
'Dim n As Long
'Dim Brr()
Stop
MsgBox Index
MsgBox k

If isEnd = "否" Then
      iStart = firstI(Arr(Index, 2), Arr)
      Stop
      MsgBox iStart
      MsgBox Arr(iStart, 1)
      MsgBox Arr(iStart, 4)
      Spread iStart, Arr(iStart, 1), Arr, Arr(iStart, 3), Arr(iStart, 4), ""
Else
      n = n + 1
      ReDim Preserve Brr(1 To 4, 1 To n)
'       MsgBox parentStr
'       MsgBox Index
'       MsgBox n
         Brr(1, n) = Arr(Index, 1)
         Brr(2, n) = Arr(Index, 2)
         Brr(3, n) = Arr(Index, 3)
         Brr(4, n) = Arr(Index, 4)
         If Index = UBound(Arr) Then
         Exit Sub
         End If
         Spread Index + 1, Arr(Index + 1, 1), Arr, Arr(iStart, 3), Arr(Index + 1, 4), ""
'          Stop
End If
End Sub
Function firstI(ByVal tmpS As String, ByVal Arr As Variant)
Dim i As Long
Dim iIndex As Long
For i = LBound(Arr) To UBound(Arr)
If Arr(i, 1) = tmpS Then
      iIndex = i
      firstI = iIndex
      Exit Function
End If
Next i

End Function

		自动登录	找回密码
密码			免费注册

[求助] Bom嵌套展开到末级（计算材料用）

评分