VBA 分层BOM问题总结

最新推荐文章于 2024-05-22 06:28:50 发布

GeorgeRhua

最新推荐文章于 2024-05-22 06:28:50 发布

阅读量1.4k

点赞数 1

分类专栏：笔记实际应用

本文链接：https://blog.csdn.net/GeorgeRhua/article/details/119542212

版权

实际应用同时被 2 个专栏收录

13 篇文章 0 订阅

订阅专栏

笔记

8 篇文章 0 订阅

订阅专栏

分层BOM问题描述：

问题分割

1、一行的Reference中有多个料号，如何遍历？

2、判断条件？通过遍历判断匹配项的Mirror吗？

分层BOM问题描述：

根据 reference和mirror的对应信息（分层信息），

将原始BOM Reference中不同mirror的分离出来，

对应Layer： (YES = BOT)，生成带有Layer信息的分层BOM(TOP+BOT)

同时更改Quantity

增加同类器件合并单元格（Item相同，可替选物料）

问题分割

1、一行的Reference中有多个料号，如何遍历？

以”,”为分隔符，存入数组中遍历

Refer = Split(Cells(i, 2), ",") '每一行Refer分为数组

For j = 0 To UBound(Refer) 'Refer数组遍历，单个元素判断

2、判断条件？通过遍历判断匹配项的Mirror吗？

用字典！

Dim dic As Object

Dim arr '用于存储单元格数据

Set dic = CreateObject("Scripting.Dictionary") '创建字典

arr = Sheet6.[a1].CurrentRegion '将Sheets6的数据放入数组

For i = 1 To UBound(arr)'返回数组相应维度最大值，默认参数Ubound(arr,1)=最大行数

dic(arr(i, 1)) = arr(i, 2) '构建字典：dic(key_name)=item

3、如何统计单元格内位号的个数？

使用字符替换Replace，和字符长度Len

Length_1 = Len(Range("D" & i)) '单元格内容总长度

Range("C" & i) = Range("D" & i) '内容转移，因为Replace会改变单元格本身的内容

str = Range("C" & i).Replace(",", "") 'Replace不能单独使用，必须是赋值语句

Length_2 = Len(Range("C" & i)) '用空字符替换","后的长度

Range("C" & i) = Length_1 - Length_2 '前面有多余的","，故不需要加一

总代码（*变动）

Sub 分层BOM()
    '先调用函数清除之前生成sheets内容
    Call 清空生成Sheets

    'sheet1 复制到 TOP和BOT
    Sheets("原始BOM").Cells.Copy Sheets("TOP").[a1]
    Sheets("原始BOM").Cells.Copy Sheets("BOT").[a1]
    
    '从sheets("分层信息")创建字典
    Dim dic As Object
    Dim arr     '用于存储单元格数据
    Set dic = CreateObject("Scripting.Dictionary") '创建字典
    arr = Sheets("分层信息").[a1].CurrentRegion    '将sheets("分层信息") 的数据放入数组
    
    Dim i, j%
    For i = 1 To UBound(arr)    '返回数组相应维度最大值，默认参数Ubound(arr,1)=最大行数
        dic(arr(i, 1)) = arr(i, 2)  '构建字典：dic(key_name)=item
    Next
    
    
   'try 创建dic2 key 与 dic 相同
    Set dic2 = CreateObject("Scripting.Dictionary") '创建字典
    For Each k In dic.Keys
         dic2(k) = dic(k)
    Next
    
    '操作sheets("原始BOM")判断Reference，分到TOP和BOT指定栏目
    Sheets("原始BOM").Select
    Dim Refer
    Dim str
    Dim LastRow& 'long
    Dim LastRow_B&
    LastRow = Range("a65536").End(xlUp).Row '取a列的最大行数
    
    '清空TOP与BOT的Reference项，避免累加复制出错！
    Sheets("TOP").Select
    Range(Cells(2, "H"), Cells(LastRow, "H")).Select
    Selection.ClearContents
    Sheets("BOT").Select
    Range(Cells(2, "H"), Cells(LastRow, "H")).Select
    Selection.ClearContents
    
    For i = 2 To LastRow
        Sheets("原始BOM").Select '回到原始BOM提取数据！！！！
        Refer = Split(Sheets("原始BOM").Cells(i, "H"), ",")     'H列的每一行Refer分为数组
        
        '第i行的Refer逐个判断，复制到BOT 和 TOP
        For j = 0 To UBound(Refer)          'Refer数组遍历，单个元素判断
            If dic(Refer(j)) = "YES" Then
                Sheets("BOT").Range("H" & i) = Sheets("BOT").Range("H" & i) & "," & Refer(j) 'Item=YES的，存入BOT
                If dic2.exists(Refer(j)) Then  '必须存在，才可以remove，不能重复remove
                    dic2.Remove Refer(j)
                End If
            ElseIf dic(Refer(j)) = "NO" Then
                Sheets("TOP").Range("H" & i) = Sheets("TOP").Range("H" & i) & "," & Refer(j) '累加复制，必须初始单元格为空
                'dic2.Remove Refer(j)   报错？？？？？
                If dic2.exists(Refer(j)) Then  '必须存在，才可以remove，不能重复remove
                    dic2.Remove Refer(j)
                End If
            Else '这里没有“Then”
                MsgBox ("分层信息有误，未能匹配到分层信息")
                Sheets("TOP").Range("H" & i).Style = "差"
                Sheets("BOT").Range("H" & i).Style = "差"
                Exit Sub    '未能检索到分层信息，退出去
            End If
        Next
        
        '计算数目，注意此时非空reference单元格会有多余字符","
        Sheets("TOP").Select
        Length_1 = Len(Range("H" & i)) '单元格内容总长度
        Range("G" & i) = Range("H" & i) '内容转移，因为Replace会改变单元格本身的内容
        str = Range("G" & i).Replace(",", "") 'Replace不能单独使用，必须是赋值语句
        Length_2 = Len(Range("G" & i)) '用空字符替换","后的长度
        Range("G" & i) = Length_1 - Length_2  '前面有多余的","，故不需要加一
        '删除最左侧的多余","
        If Len(Range("H" & i)) > 0 Then
            Range("H" & i) = Right(Range("H" & i), Len(Range("H" & i)) - 1)
        End If
        
        '对 BOT 执行同样操作
        Sheets("BOT").Select
        Length_1 = Len(Range("H" & i)) '单元格内容总长度
        Range("G" & i) = Range("H" & i) '内容转移，因为Replace会改变单元格本身的内容
        str = Range("G" & i).Replace(",", "") 'Replace不能单独使用，必须是赋值语句
        Length_2 = Len(Range("G" & i)) '用空字符替换","后的长度
        Range("G" & i) = Length_1 - Length_2  '前面有多余的","，故不需要加一

       If Len(Range("H" & i)) > 0 Then
            Range("H" & i) = Right(Range("H" & i), Len(Range("H" & i)) - 1)
       End If
        
    Next
    
    '分层判断完成，筛选出不贴的位号
    Sheets("NC_Item").Select
    Range("a1").Resize(dic2.Count, 1) = Application.Transpose(dic2.Keys)
    Range("a1") = "NC_Reference"
    Range("A1").Select
    Selection.Style = "40% - 着色 1"
    
    '空的Reference执行删除行操作，
    For i = LastRow To 2 Step -1    '注意删除行是上移，则遍历顺序自下而上
        Sheets("BOT").Select
        If Cells(i, "H") = "" Then
            Sheets("BOT").Rows(i & ":" & i).Select  '注意行选中的参数！
            Selection.Delete Shift:=xlUp
        End If
        
        Sheets("TOP").Select        '下面引用sheets().cells()报错？？
        If Cells(i, "H") = "" Then
            Sheets("TOP").Rows(i & ":" & i).Select  '注意行选中的参数！
            Selection.Delete Shift:=xlUp
        End If
    Next
    
    '添加Layer信息
 'TOP   '表头格式设置
    Sheets("TOP").Select
    Range("A1:I1").Select
    Selection.Style = "40% - 着色 1"
    [I1] = "Layer"
    '赋值"TOP"
    LastRow = Sheets("TOP").Range("a65536").End(xlUp).Row '取TOP的最大行数
    Range(Cells(2, "I"), Cells(LastRow, "I")).Select
    Selection.FormulaR1C1 = "TOP"
     
    'TOP 复制到 分层BOM
    Sheets("TOP").Cells.Copy Sheets("分层BOM").[a1]
 
 'BOT  '表头格式设置
    Sheets("BOT").Select
    Range("A1:I1").Select
    Selection.Style = "40% - 着色 1"
    [I1] = "Layer"
    '赋值"BOT"
    LastRow_B = Sheets("BOT").Range("a65536").End(xlUp).Row '取BOT的行数：LastRow_B
    Range(Cells(2, "I"), Cells(LastRow_B, "I")).Select
    Selection.FormulaR1C1 = "BOT"
    
    '复制BOT到剪贴板
    Range(Cells(1, "A"), Cells(LastRow_B, "I")).Select  '注意是BOT的最大行
    Selection.Copy
    Sheets("分层BOM").Select
    Range("A" & LastRow + 1).Select 'LastRow是TOP的最大行数,注意要+1
    'Sheets("分层BOM").Range("A" & LastRow + 1).Select 此句语法错误
    
    ActiveSheet.Paste
    Application.CutCopyMode = False '清空剪贴板
        
    '执行完毕
    MsgBox ("执行完毕")
End Sub

更新日志：

调试选项：清空生成的Sheets

Sub 清空生成Sheets()
'
    Sheets("TOP").Select
    Cells.Select
    Selection.ClearContents
    Selection.Style = "Normal"
    Sheets("BOT").Select
    Cells.Select
    Selection.ClearContents
    Selection.Style = "Normal"
    Sheets("分层BOM").Select
    Cells.Select
    Selection.ClearContents
    Selection.Style = "Normal"
    
End Sub

单个sheet导出为.xlsx文件

Sub 导出分层BOM_xlsx()

    Sheets("分层BOM").Copy
    
    Set wb = ActiveWorkbook
    wb.SaveAs ThisWorkbook.Path & "\分层BOM.xlsx"
    wb.Close
    MsgBox ("分层BOM.xlsx 已导出到当前目录")
End Sub

分层判断条件报错提示

同类Item单元格合并

关键问题：

1、自下而上遍历，两两对比判断

2、直接执行 Selection.Merge

3、取消对话框弹出

Sub 合并同类项_分层BOM()
'
    Application.DisplayAlerts = False   '避免每次弹出对话框
    
    Sheets("分层BOM").Select
    Dim i&
    Dim LastRow& 'long
    LastRow = Range("a65536").End(xlUp).Row '取a列的最大行数
    
    For i = LastRow To 2 Step -1
        If Range("A" & i) = Range("A" & i - 1) Then     '使用Item作为判断条件
            Range(Cells(i, "A"), Cells(i - 1, "A")).Select
            Selection.Merge     '直接使用此语句，比调用完整宏快
            'Call Selection_Merge
            Range(Cells(i, "C"), Cells(i - 1, "C")).Select
            Selection.Merge
            Range(Cells(i, "G"), Cells(i - 1, "G")).Select
            Selection.Merge
            Range(Cells(i, "H"), Cells(i - 1, "H")).Select
            Selection.Merge
            Range(Cells(i, "I"), Cells(i - 1, "I")).Select
            Selection.Merge
        End If
    Next
    
    Application.DisplayAlerts = True    '注意改回来
    
End Sub

数据格式不同合并单元格失败

先进行格式归一化

'A列格式转换数值 to 常规

'涉及到单元格比较的，必须注意数据格式！！！

Range("A:A").Select

Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _

Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _

:=Array(1, 1), TrailingMinusNumbers:=True

NC（不贴物料检索出来）

思路：创建与分层信息字典dic一样的dic2

对于原始BOM中存在的Reference，判断分层的同时，从dic2中Remove相应的Key

注意：dic2.Remove key ‘如果 key 不存在，会报错！

故，首先判断存在性：if dic2.exists(key) then

最后，输出不需要贴装的位号在“NC_Item”

GeorgeRhua

关注

1
点赞
踩
7

收藏

觉得还不错? 一键收藏
2
评论
VBA 分层BOM问题总结

分层BOM问题描述：根据 reference和mirror的对应信息，将BOM Reference中不同mirror的分离出来，对应Layer： (YES = BOT)，同时更改Quantity最终生成TOP与BOT分类的BOM表问题分割1、一行的Reference中有多个料号，如何遍历？以”,”为分隔符，存入数组中遍历 Refer = Split(Cells(i, 2), ",") '每一行Refer分为数组 For j = 0 To U...
复制链接

扫一扫