按照BOM拆解需求计划

opiona · 发表于 2021-5-19 17:38

本帖最后由 opiona 于 2021-5-19 23:13 编辑

看到很多: 按照BOM拆解需求计划  例如:http://club.excelhome.net/thread-1585438-1-1.html
才发现原来做的递归解法效率不是很高  于是进行了修改
发出来  供大家参考:
附件已经简化见2楼可以更直观看到结果

代码:

Option Explicit '//强制声明变量
Dim BRX, ZBC, ZBD, PRX, ZPD
Dim INTX As Long
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, 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编号,父项物料代码,父项物料名称,父项物料规格型号,父项物料数量,子项物料代码,子项物料名称,子项物料规格型号,子项物料单位用量,审核时间
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)
ZBD("" & BRX(X, ZBC("父项物料规格型号"))) = "" & BRX(X, ZBC("子项物料规格型号"))
Next
Rem 需求计划数值父件+数量
Set SHX = Worksheets("源表")
SHX.AutoFilterMode = False '//取消筛选
MAXCOL = SHX.Range("IT1").End(xlToLeft).Column
Set ZCC = CreateObject("Scripting.Dictionary")
For ICOL = 1 To MAXCOL
ZCC(SHX.Cells(1, ICOL).Value) = ICOL
Next
MAXROW = SHX.Range(SHX.Cells(SHX.Rows.Count, ZCC("规格")).Address).End(3).Row
CRX = SHX.Range("A1:" & SHX.Cells(MAXROW, MAXCOL).Address).Value
Rem 初始化公共变量保存结果 PRX
INTX = 0
ReDim PRX(1 To 2, 1 To 1) '//输出结果数组，需转置
Set ZPD = CreateObject("Scripting.Dictionary") '//记录那些ID已经存在就直接相加
Rem 开始了!
For X = 2 To UBound(CRX, 1)
Rem 调用函数父件+数量
Call GETBOM("" & CRX(X, ZCC("规格")), Val(CRX(X, ZCC("数量"))))
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
Rem BOM表父件中查找此ID
For X = 2 To UBound(BRX, 1)
If "" & BRX(X, ZBC("父项物料规格型号")) = StrID Then
If ZBD.EXISTS("" & BRX(X, ZBC("子项物料规格型号"))) Then
Rem 如果还有下一层，则：万恶的递归开始了
Call GETBOM(BRX(X, ZBC("子项物料规格型号")), Val(BRX(X, ZBC("子项物料单位用量"))) * DOU)
Else
Rem 判断结果数组PRX中是否存在此ID
If ZPD(BRX(X, ZBC("子项物料规格型号"))) Then
Else
Rem 结果数组中不存在此ID，则增加一个ID
INTX = INTX + 1
ZPD(BRX(X, ZBC("子项物料规格型号"))) = INTX
ReDim Preserve PRX(1 To UBound(PRX, 1), 1 To INTX)
PRX(1, INTX) = "" & BRX(X, ZBC("子项物料规格型号"))
End If
Rem 用量
IROW = ZPD(BRX(X, ZBC("子项物料规格型号")))
PRX(2, IROW) = Val(PRX(2, IROW)) + Val(BRX(X, ZBC("子项物料单位用量"))) * DOU '//百分比要除：100，用量则不需要
End If
End If
Next
End Sub
Rem *************************************************************
Rem 二维数组转置
Rem 参数：ARR 一个二维数组
Rem 输出：一个二维数组
Rem 使用方法：
' Dim ARR() '//作为参数的数组，要先声明
' ARR = Sheet1.Range("A1:B4").Value '//赋值给数组
' BRR = TransposeTWO(ARR) '//转置后的数组，可以不用实现声明
' CRR = Application.Transpose(FileArr) '//转置，一维数组变成竖排
Rem 北极狐工作室整理，QQ：14885553
Rem *************************************************************
Public Function TransposeTWO(ARR) As Variant
Dim X, Y, LB As Long
LB = LBound(ARR, 1)
ReDim ARX(LB To UBound(ARR, 2), LB To UBound(ARR, 1))
For Y = LB To UBound(ARR, 2)
For X = LB To UBound(ARR, 1)
ARX(Y, X) = ARR(X, Y)
Next X
Next Y
TransposeTWO = ARX
End Function

复制代码

opiona · 发表于 2021-5-19 23:09

附件已经简化可以更直观看到结果

BOM拆解-递归-升级版.rar (32.93 KB, 下载次数: 94)

fjwyn · 发表于 2021-5-21 17:24

opiona 发表于 2021-5-19 23:09
附件已经简化可以更直观看到结果

老师如果A02的下级BOM中的物料B01已经有库存两个，如何能得到正确的结果？？？？

liao_xin · 发表于 2021-5-21 17:44

不错不错，学习中。

YANWEI82123300 · 发表于 2021-5-21 18:38

不错不错，学习中。

opiona · 发表于 2021-5-22 13:02

fjwyn 发表于 2021-5-21 17:24
老师如果A02的下级BOM中的物料B01已经有库存两个，如何能得到正确的结果？？？？

那就更复杂一些了
可以参考37楼: http://club.excelhome.net/thread-1408935-1-1.html

opiona · 发表于 2022-11-25 13:24

数据多了发现速度很慢
现在改进了递归和字典速度提升很多

BOM递归拆解_缺料运算扣库存_字典更快.rar (187.99 KB, 下载次数: 80)

今铭昔 · 发表于 2023-9-2 17:36

opiona · 发表于 2023-9-2 18:46

tomxie 发表于 2023-9-2 18:28
大概看了一下，VBA 代码有230行左右，如果用SQL，应当不会超过15行，时间估计大约0.1秒。

SQL对多层的BOM拆解适应性较差
以前做过SQL的有限层级的见一楼的链接

山海风云轩 · 发表于 2023-9-2 19:08

做个记号，学习学习

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

[分享] 按照BOM拆解需求计划

评分

评分