求助用VBA转换不定层级数的BOM表

topman-gang · 发表于 2016-12-25 22:55

本帖最后由 topman-gang 于 2016-12-27 20:38 编辑

希望本论坛的各位热心的大神们能帮我解开思路：用一个已经存在的老BOM表生成一个新格式的BOM表，有这样一个过程的原因是公司最近添加了ERP系统，要把老的BOM文件导入到新系统里，但是只能按照新系统要求的格式组织数据，否则ERP不能正确识别。我的这个工作已经拖了很长时间了，一直在EXCELHOME论坛里学习相关知识希望能够独立完成，可是越来越迷糊了，只好开贴求助。

我将老、新格式的BOM分别放在了工用表的左、右两侧，方便说明。实际用的时应该是两个不同的表，而且得按行来组织数据。
现状：
1.左侧是原来的BOM格式，存放在“总单”工作表内。
2.老格式的BOM总是最先列出顶层物料名，即机型名称；
3.再依次列出第1层的所有物料，第2层所有物料，第3层所有物料……，直到最后一层
4.第1列内容是上一级物料名称或者是同级物料的序号，如果有物料名称但没有序号，则表示这个物料是上一行物料的替代品，替代物料也可能有多个。

想要实现的格式：
1.如右侧所示，第1列是物料的层次，不再标序号；
2.先列出第1层级相关联的第1个下一层物料，再列出第1个下下层物料，直到层级分支不可再细分，才列出最小层级的全部物料；
3.再列出第1层级相关联的第2个下一层物料，直至本分支最小层级的全部物料，以此类推；
4.老格式中物料的序号列是空的行在新格式的“层次”列中用字母“R”标示，否则标示出该物料的层级数

附件内是一个真实的BOM清单，只是把物料名称改成了比较容易理解的带层级关系的名字，感觉不太好描述这个需求，请各位热心的老师们先看一下附件内容，如果不明白我的意思请您提出来，我再解释。不过很有可能看了示例就清楚我要表达的意思了。谢谢啦！十分感谢各位抽出宝贵时间帮助我！！在此提前祝excelhome论坛的朋友们元旦快乐！

topman-gang · 发表于 2016-12-25 23:01

下面是我自己写的第6个版本VBA了，还是和实际需求相差太多，越写越不知道如何下手了。请各位前辈指教！

'版本V0.6

Sub BOMList6()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("BOM").UsedRange.Clear

Dim lastRow As Long
Dim i, j, n As Long
Dim StartLayer1 As Long
Dim MaxLayer1 As Long
Dim myFindRow As Long
Dim myFind As Range
Dim LayerNum As Long

'判定是否是BOM单，要求第二行第一列内容是顶层BOM名
lastRow = Sheets("总单").Range("A65535").End(xlUp).Row       '计算BOM总单表总行数
If IsNumeric(Sheets("总单").Cells(2, 1).Value) = True Or Sheets("总单").Cells(2, 1).Value = "" Then                '判断总单第2行第1列是否有字符,如果有,则内容就是顶层BOM
      MsgBox "请确认顶层BOM号是否在第" & 2 & "列第" & 1 & "行！", , "技术部BOM格式化"
      Sheets("总单").Cells(2, 1).Select
      Exit Sub
End If

'复制"总单"表头和顶层BOM名到"BOM"表,并在和第1列加"层次"项

Sheets("总单").Rows("1:2").Copy Sheets("BOM").Rows(1)
With Sheets("BOM")
.Columns("A:A").Insert Shift:=xlToRight
.Range("A1").Value = "层次"
.Range("B1").Value = "BOM编码"
.Cells(2, 1).Value = 0
.Range("C1").Delete Shift:=xlToLeft
.Range("C2").Delete Shift:=xlToLeft
End With

'从第1层BOM开始拆分重组

j = 3
LayerNum = 1

For i = 3 To lastRow
      If Not Sheets("总单").Cells(i, 2).Value = "" Then
         Sheets("总单").Rows(i).Copy Sheets("BOM").Rows(j)
         Sheets("BOM").Cells(j, 1) = LayerNum
      End If

      Set myFind = Worksheets("总单").Range("A1:A" & lastRow).Find(Worksheets("总单").Cells(i, 2), , , xlWhole)
      Do
         j = j + 1
         LayerNum = LayerNum + 1
         myFindRow = myFind.Row
         Do
            myFindRow = myFindRow + 1
            If WorksheetFunction.CountA(Sheets("总单").Rows(myFindRow)) = 0 Then
                  Exit Do
            Else
                  If Not Sheets("总单").Cells(myFindRow, 2).Value = "" Then
                     Sheets("总单").Rows(myFindRow).Copy Sheets("BOM").Rows(j)
                     If Sheets("总单").Cells(myFindRow, 1) = "" Then
                        Sheets("BOM").Cells(j, 1) = "R"
                        j = j + 1
                     Else
                        Sheets("BOM").Cells(j, 1) = LayerNum
                        j = j + 1

                     End If
                     Set myFind = Worksheets("总单").Range("A1:A" & lastRow).Find(Worksheets("总单").Cells(myFindRow, 2), , , xlWhole)

                  End If
            End If
         Loop Until myFind Is Nothing
      Loop Until myFind Is Nothing



Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

topman-gang · 发表于 2016-12-26 14:02

昨天写了这个求助贴以后思路比以前清晰一些了，原来写求助也可以帮助自己：）

topman-gang · 发表于 2016-12-26 14:06

topman-gang · 发表于 2016-12-27 00:36

本帖最后由 topman-gang 于 2016-12-27 00:44 编辑

继续求助!! 各位老师好！经过学习，现在能做到把第1层第1个物料逐级拆分到最后一层了。但是还没有做到所有物料拆分重组。如果哪位能赐教不胜感激！先谢过啦！

以下是笨鸟写的第7版代码。。。。可能和本人一样笨，见笑啦！

Sub BOMList7()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim lastRow As Long
Dim myFind As Range
Dim LayerNum, BomRow, ZDRow, i As Long

Sheets("BOM").UsedRange.Clear
'判定是否是BOM单，要求第二行第一列内容是顶层BOM名
lastRow = Sheets("总单").Range("A65535").End(xlUp).Row       '计算BOM总单表总行数
If IsNumeric(Sheets("总单").Cells(2, 1).Value) = True Or Sheets("总单").Cells(2, 1).Value = "" Then                '判断总单第2行第1列是否有字符,如果有,则内容就是顶层BOM
      MsgBox "请确认顶层BOM号是否在第" & 2 & "列第" & 1 & "行！", , "技术部BOM格式化"
      Sheets("总单").Cells(2, 1).Select
      Exit Sub
End If

'复制"总单"表头和顶层BOM名到"BOM"表,并修改表头

Sheets("总单").Rows("1:2").Copy Sheets("BOM").Rows(1)
With Sheets("BOM")
      .Cells(1, 1).Value = "层次"
      .Cells(1, 2).Value = "BOM编码"
      .Cells(2, 2).Value = .Cells(2, 1).Value
      .Cells(2, 1).Value = 0
End With

'循环处理从1层第1个物料开始的逐层级第1个物料,直到最后一层所有物料停止

LayerNum = 1
BomRow = 3
ZDRow = 3

Do
      i = 1

      If Not Sheets("总单").Cells(ZDRow, 2) = "" Then       '如果有第1层第1个物料,则开始拆分,否则提示错误并退出
         Set myFind = Sheets("总单").Range("A1:A" & lastRow).Find(Worksheets("总单").Cells(ZDRow, 2), , , xlWhole)
         If myFind Is Nothing Then          '是最后一级物料时
            If Sheets("总单").Cells(ZDRow + i, 2) = "" Then          '同级物料最后一行第2列是空,则退出
                  Exit Do
            Else
                  i = 1                         '复制同级物料
                  Do
                     Do While Sheets("总单").Cells(ZDRow + i, 1) = ""
                        '总单当前行第1列是空值,则表示是替代物料,BOM表相应行第1列标"R"

                        Sheets("总单").Rows(ZDRow + i).Copy Sheets("BOM").Rows(BomRow)
                        Sheets("BOM").Cells(BomRow, 1) = "R"
                        Sheets("BOM").Cells(BomRow, 1).HorizontalAlignment = xlRight
                        ZDRow = ZDRow + 1
                        BomRow = BomRow + 1
                        If Sheets("总单").Cells(ZDRow + i, 2) = "" Then
                              Exit Sub
                        End If

                     Loop

                     Sheets("总单").Rows(ZDRow + i).Copy Sheets("BOM").Rows(BomRow)
                     Sheets("BOM").Cells(BomRow, 1) = LayerNum - 1

                     i = i + 1
                     BomRow = BomRow + 1
                  Loop Until Sheets("总单").Cells(ZDRow + i, 2) = ""
            End If

         Else                               '逐级复制每层第1个物料
            If ZDRow = 3 Then             '如果总单第3行是第1层物料,则复制到BOM第3行
                  Sheets("总单").Rows(ZDRow).Copy Sheets("BOM").Rows(BomRow)
                  Sheets("BOM").Cells(BomRow, 1) = LayerNum
                  BomRow = BomRow + 1
                  LayerNum = LayerNum + 1

            End If

            Sheets("总单").Rows(myFind.Row + i).Copy Sheets("BOM").Rows(BomRow)
            Sheets("BOM").Cells(BomRow, 1) = LayerNum
            i = i + 1
            LayerNum = LayerNum + 1
            BomRow = BomRow + 1
            ZDRow = myFind.Row + 1
         End If
      Else
         Sheets("BOM").UsedRange.Clear                '清空BOM表
         MsgBox "请确认是否有第1层物料!"                '总单第3行第2列没有数据,报错

         Exit Sub

      End If
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

topman-gang · 发表于 2016-12-27 00:41

不好意思，刚才说错了，我只做到了把第1个1级物料的每层的第1个物料及最后一层的全部物料重组出来。想要的结果是“最终的BOM”表里那个样子的，感觉任重道远啊。。。

层次 BOM编码组件描述用量单位位号
0 机型名称
1 物料1.1 构成该机型的第1种部品 1 SET
2 物料1.1.1 构成[物料1.1]的第1种部品名 1 SET
3 物料1.1.1.1 构成[物料1.1.1]的第1种部品名 1 SET
4 物料1.1.1.1.1 构成[物料1.1.1.1]的第1种部品名 1 SET
4 物料1.1.1.1.2 构成[物料1.1.1.1]的第2种部品名 1 SET
4 物料1.1.1.1.3 构成[物料1.1.1.1]的第3种部品名 1 SET
R 物料1.1.1.1.4 序号为空,可替代上一行部品的物料 1 SET

topman-gang · 发表于 2016-12-27 10:54

再继续一边求助一边自己捣鼓:) 希望各位老师有时间能帮忙看一下,谢谢!

topman-gang · 发表于 2016-12-27 13:18

哪位网友知道有类似的帖子吗?能否转发一下?谢谢!

topman-gang · 发表于 2016-12-27 20:36

非常高兴有朋友下载附件！不管有没有结果都很感谢！

topman-gang · 发表于 2016-12-31 23:54

网友们还有10分钟就新年了,祝各位元旦快乐!
还是同一个问题,为了能更清楚的表达意思,画了一张数据拓扑结构图,每个数据节点代表一行数据的,节点编号就是我需要的排列顺序,即从1号\2号\3号,一直到40。再问一下，有没有朋友可以帮忙分析一下？谢谢啦！

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