BOM层次及汇总表=180624

Sub 格式化项目号()
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)
    
    最大级数 = 1
    For Each 行 In 表字典.items
        行("项目号").Select
        a = Split(行("项目号"), ".")
        最大级数 = IIf(UBound(a) + 1 > 最大级数, UBound(a) + 1, 最大级数)
    Next
'    Debug.Print 最大级数
    
    Set 级数字典 = CreateObject("Scripting.Dictionary")
    For 级数 = 1 To 最大级数
        Set 级数字典(级数) = CreateObject("Scripting.Dictionary")
    Next
    For Each 行 In 表字典.items
        行("项目号").Select
        a = Split(行("项目号"), ".")
        当前行级数 = UBound(a) + 1
        For 级数 = 1 To 当前行级数
            级数字典(级数)(行) = a(级数 - 1)
        Next
    Next
    
    For Each 级数 In 级数字典.keys
        最大长度 = 1
        For Each 级数数值 In 级数字典(级数).items
'            Debug.Print 级数数值 & "==" & Len(级数数值)
            最大长度 = IIf(Len(级数数值) > 最大长度, Len(级数数值), 最大长度)
        Next
        占位零 = String(最大长度, "0")
        For Each k In 级数字典(级数).keys
            级数数值 = 级数字典(级数)(k)
'            Debug.Print Format(级数数值, 占位零)
            格式化级数数值 = Format(级数数值, 占位零)
            级数字典(级数)(k) = 格式化级数数值
        Next
    Next
    
    For Each 行 In 表字典.items
        行("项目号").Select
        新项目号 = ""
        For Each 级数 In 级数字典.keys
            级数数值 = 级数字典(级数)(行)
            
            新项目号 = IIf(级数数值 = "", 新项目号, 新项目号 & "." & 级数数值)
        Next
        新项目号 = Mid(新项目号, 2)
        Debug.Print 新项目号
        行("项目号").Value = 新项目号
    Next
    
End Sub
Sub cs()
Debug.Print String(5, "0")

End Sub

Public swApp As Object, swModel As Object, swFeatMgr As Object, swConfigMgr As Object
Public selData As Object, SelMgr As Object
Public lstatus As Long, lwarnings As Long, lErrors As Long
Public FilePath, Filename, FilenameWHZ As String
Public swFileTYpe As Integer
Public 坐标对象 As Object
Sub sw初始化(ByVal sw全名)
    Set swApp = CreateObject("SldWorks.Application") '启动SW
    If sw全名 = "" Then
        Set swModel = swApp.ActiveDoc
        sw全名 = swModel.GetPathName
    End If
    Call 拆分文件名(sw全名)
    Call 类型判断(sw全名)
    Set swModel = swApp.OpenDoc(sw全名, swFileTYpe) '开启档案
    Set swModel = swApp.ActivateDoc3(sw全名, False, 0, lErrors)
    swset
End Sub
Sub sw初始化_获取指定文件(ByVal sw全名)
    Set swApp = CreateObject("SldWorks.Application") '启动SW
    Call 类型判断(sw全名)
    Set swModel = swApp.GetOpenDocumentByName(sw全名)
    If swModel Is Nothing Then
        Set swModel = swApp.OpenDoc(sw全名, swFileTYpe)
        swModel.Visible = False
    End If
    swset
End Sub
Sub 拆分文件名(ByVal FilePathName)
    FilePath = Left(FilePathName, InStrRev(FilePathName, "\")) '分解路径
    Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解文件名
    FilenameWHZ = Left(Filename, Len(Filename) - 7)
End Sub
Sub 类型判断(ByVal FilePathName)
    If UCase(Right(FilePathName, 3)) = "PRT" Then swFileTYpe = 1
    If UCase(Right(FilePathName, 3)) = "LFP" Then swFileTYpe = 1
    If UCase(Right(FilePathName, 3)) = "ASM" Then swFileTYpe = 2
    If UCase(Right(FilePathName, 3)) = "DRW" Then swFileTYpe = 3
    If UCase(Right(FilePathName, 6)) = "DRWDOT" Then swFileTYpe = 3
End Sub
Sub swset()
    Set swFeatMgr = swModel.FeatureManager
    Set SelMgr = swModel.SelectionManager
    Set selData = SelMgr.CreateSelectData
    Set swConfigMgr = swModel.ConfigurationManager
End Sub
Sub 激活窗口()
    If Range("激活sw窗口方式") = "AppActivate" Then
        窗口标题集 = Array( _
        Filename & " - 图纸1", _
        Filename & " - 图纸1 *", _
        FilenameWHZ & " - 图纸1", _
        FilenameWHZ & " - 图纸1 *", _
        FilenameWHZ & " - 图纸2", _
        FilenameWHZ & " - 图纸2 *", _
        Filename, _
        Filename & " *", _
        FilenameWHZ, _
        FilenameWHZ & " *" _
        )
        For Each 窗口标题 In 窗口标题集
            On Error Resume Next
            AppActivate 窗口标题
            If Err.Number <> 0 Then
                Err.Clear
            Else
                Exit For
            End If
        Next
    Else
        sw全名 = swModel.GetPathName
        cmd = "explorer.exe """ & sw全名 & """"
        Shell cmd, 1
    End If
End Sub
Function 映射特征类型(ByVal 原特征类型) As String
    Set d = CreateObject("scripting.dictionary")
    d.Add "ICE", "BODYFEATURE"
    d.Add "Chamfer", "BODYFEATURE"
    d.Add "ProfileFeature", "SKETCH"
    d.Add "DeleteBody", "BODYFEATURE"
    d.Add "BaseBody", "BODYFEATURE"
    d.Add "Cut", "BODYFEATURE"
    d.Add "LPattern", "BODYFEATURE"
    d.Add "HoleWzd", "BODYFEATURE"
    d.Add "Reference", "COMPONENT"
    d.Add "MirrorPattern", "BODYFEATURE"
    d.Add "LocalLPattern", "COMPPATTERN"
    
    If d.Exists(原特征类型) Then
        映射特征类型 = d(原特征类型)
    End If
End Function
Sub 映射图纸大小(ByRef 映射字典)
    Set 映射字典("swto俗称") = CreateObject("scripting.dictionary")
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA3size, "A3"
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA2size, "A2"
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA4sizeVertical, "A4"
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA4size, "A4横"
    
    Set 映射字典("俗称tosw") = CreateObject("scripting.dictionary")
    For Each k In 映射字典("swto俗称")
        映射字典("俗称tosw").Add 映射字典("swto俗称")(k), k
    Next
End Sub
Sub 激活窗口cs()
    Set 窗口标题集 = CreateObject("Scripting.Dictionary")
    窗口标题集.Add "00_kz", ""
    
    For Each 窗口标题 In 窗口标题集.keys
        On Error Resume Next
        AppActivate 窗口标题
        If Err.Number <> 0 Then
            Err.Clear
        Else
            Exit For
        End If
    Next
End Sub

Public Const Const阵列类型名称 As String = "LocalCirPattern|MirrorCompFeat|LocalLPattern|LocalSketchPattern|DerivedHolePattern"
Public Const Const删除项 As String = "参考|ck|作废"
Public Const Const活动项 As String = "活动|运动"
Function 含删除项(ByVal 查找范围) As Boolean
    a = Split(Const删除项, "|")
    For i = 0 To UBound(a)
        If InStr(1, 查找范围, a(i), 1) <> 0 Then
            含删除项 = True
            Exit For
        End If
    Next
End Function
Sub 测试含删除项()
    Call 含删除项("ck")
    Debug.Print 含删除项("ck")
    kk = 含删除项("ck")
    Debug.Print kk
End Sub
Function 含活动项(ByVal 查找范围) As Boolean
    a = Split(Const活动项, "|")
    For i = 0 To UBound(a)
        If InStr(1, 查找范围, a(i), 1) <> 0 Then
            含活动项 = True
            Exit For
        End If
    Next
End Function
Function 含其中之一(ByVal 查找范围, ByVal 关键词) As Boolean
    a = Split(关键词, "|")
    For i = 0 To UBound(a)
        If InStr(1, 查找范围, a(i), 1) <> 0 Then
            含其中之一 = True
            Exit For
        End If
    Next
End Function
Function 在列表中(ByVal 关键词, ByVal 列表) As Boolean
    For Each 列表项 In 列表
        If 列表项 = 关键词 Then
            在列表中 = True
            Exit For
        End If
    Next
End Function
Function 含其中之一V2(ByVal 查找范围, ByVal 关键词数组) As Boolean
    For Each 关键词 In 关键词数组
        If InStr(1, 查找范围, 关键词, 1) <> 0 Then
            含其中之一V2 = True
            Exit For
        End If
    Next
End Function

Sub 粘贴字典(ByVal 字典, ByVal 表名, ByRef 新表头行)
    Sheets(表名).Activate
'    Sheets(表名).Select
'    新首行 = Sheets("原材料汇总表").Range(新表头行).Row + 1
    Range(表名 & "标题") = "<<" & Range("顶层代号") & Range("顶层名称") & ">> " & 表名
    
    新首行 = Range(新表头行).Row + 1
    新首列 = Range(新表头行).Column
    If Cells(新首行, 新首列) <> "" Then
        新末行 = Cells(新首行, 新首列).End(xlDown).Row
    Else
        新末行 = 新首行
    End If
    
    Cells.EntireColumn.Hidden = False
    新末列 = Range(新表头行).End(xlToRight).Column
'    新末列 = 10
    On Error Resume Next
    Set 原区域 = Cells(新首行, 1).Resize(新末行 - 新首行 + 1, 新末列)
    原区域.Interior.Pattern = xlNone
    原区域.ClearContents
    
    当前行 = 新首行
    For Each 行 In 字典.items
        For 列号 = 新首列 To 新末列
            k = Cells(新首行 - 1, 列号)
            If 行.Exists(k) Then
                Cells(当前行, 列号) = 行(k).Value
            End If
            If k = "总计" Then
                Cells(当前行, 列号) = 行("原材料总计").Value
'            ElseIf k = "名称及规格" Then
''                Cells(当前行, 列号) = 行("名称").Value & 行("规格").Value
'                Cells(当前行, 列号) = 行("名称").Value
            ElseIf k = "数量" Then
                Cells(当前行, 列号) = 行("每台数量").Value
            ElseIf k = "单重" Then
                Cells(当前行, 列号) = 行("重量").Value
            ElseIf k = "总重" Then
                Cells(当前行, 列号) = 行("重量").Value * 行("每台数量").Value
            ElseIf k = "层级代号" Then
                Cells(当前行, 列号) = 行("项目号").Value
            ElseIf k = "备注" Then
                If Not 含其中之一(表名, "BOM清单|图纸下发清单") Then
                    新备注值 = Replace(行("备注").Value, "激光下料", "")
                Else
                    新备注值 = 行("备注").Value
                End If
                Cells(当前行, 列号) = 新备注值
            End If
        Next
        当前行 = 当前行 + 1
    Next
    
    If Cells(新首行, 新首列) <> "" Then
        新末行 = Cells(新首行, 新首列).End(xlDown).Row
    Else
        新末行 = 新首行
    End If
    
'汇总表重新排序
If 表名 <> "BOM清单" Then
    Cells(新首行, 1).Resize(新末行 - 新首行 + 1, 新末列).Select
    With Sheets(表名).Sort
        .SortFields.Clear
        If 表名 = "原材料分项表" Then
            .SortFields.Add Key:=Columns(8)
            .SortFields.Add Key:=Columns(9)
            .SortFields.Add Key:=Columns(10)
            .SortFields.Add Key:=Columns(1)
        ElseIf 表名 = "原材料汇总表" Then
            .SortFields.Add Key:=Columns(2)
            .SortFields.Add Key:=Columns(3)
            .SortFields.Add Key:=Columns(4)
        ElseIf 表名 = "图纸下发清单" Then
            .SortFields.Add Key:=Columns(2)
        Else
            .SortFields.Add Key:=Columns(3)
            .SortFields.Add Key:=Columns(2)
'            .SortFields.Add Key:=Columns(4)
'            .SortFields.Add Key:=Columns(2)
        End If
        .SetRange Selection
        .Header = xlNo
        .Apply
    End With
End If
    
    If 表名 = "外购件及标准件汇总表" Then
'        Columns("J:J").EntireColumn.Hidden = True
    End If
    
    If Not 含其中之一(表名, "原材料分项表|BOM清单") Then
        Set fillRange = Range(Cells(新首行, 1), Cells(新末行, 1))
        fillRange.Select
        Range(新表头行).Offset(1, -1) = 1
        Cells(新首行, 1).AutoFill Destination:=fillRange, Type:=xlFillSeries
    End If
    
End Sub
Sub cs()
    新首列 = 1
'    新末列 = Sheets("原材料汇总表").Range(新表头行).End(xlRight).Column
    新末列 = Range("A2").End(xlToRight).Column
    
End Sub

Sub 算每台数量()
    格式化项目号
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)
    
    For Each 行 In 表字典.items
        行("编号").Select
'        行("编号").Value = 行("代号") & 行("名称") & 行("规格")
        行("编号").Value = 行("配置") & 行("代号") & 行("名称") & 行("规格")
        行("编号").WrapText = False
        
        本级数量 = 行("每套数量")
        至顶级数量 = 本级数量
        a = Split(行("项目号"), ".")
        If a(0) <> "" Then
            '递乘父级==开始
             For i = UBound(a) - 1 To 0 Step -1
                父级 = ""
                For j = i To 0 Step -1
                    父级 = "." & a(j) & 父级
                Next j
                父级 = Mid(父级, 2)
                
                For Each 行2 In 表字典.items
                    If 行2("项目号") = 父级 Then 至顶级数量 = 至顶级数量 * 行2("每套数量"): Exit For
                Next 行2
             Next i
             '递乘父级==结束
        End If
        行("至顶级数量").Value = 至顶级数量
        
        行("每台数量").ClearContents
        行("每台数量").Interior.ColorIndex = xlNone
    Next
    
    
    颜色 = 16711680
    Set 编号字典 = CreateObject("Scripting.Dictionary")
    For Each 行 In 表字典.items
        编号 = 行("编号")
        If Not 编号字典.Exists(编号) Then
            Set 编号字典(编号) = CreateObject("Scripting.Dictionary")
            Set 编号字典(编号)("对应行") = CreateObject("Scripting.Dictionary")
        End If
        总数 = 行("至顶级数量") + 编号字典(编号)("总数")
        编号字典(编号)("总数") = 总数
        编号字典(编号)("对应行").Add 行, ""
    Next
    
    For Each Key In 编号字典.keys
        第几个键 = 0
        For Each 行 In 编号字典(Key)("对应行").keys
            If 编号字典(Key)("对应行").Count > 1 Then
               第几个键 = 第几个键 + 1
               If 第几个键 = 1 Then
                    Set 第一个行 = 行
                    行("每台数量").Value = 编号字典(Key)("总数")
               Else
                    行("每台数量").Formula = "=" & 第一个行("每台数量").Address(False, False)
               End If
               行("每台数量").Interior.Color = 颜色
            Else
                行("每台数量").Value = 编号字典(Key)("总数")
            End If
        Next
        颜色 = 颜色 - 20000
    Next

'    MsgBox "Done!", vbInformation
End Sub
Sub 算每台数量2()
    Set 列d = CreateObject("Scripting.Dictionary")
    Call 识别表头(列d)
    For 当前行 = 表头行 + 1 To 末行
        行("编号").Select
            行("编号") = Cells(当前行, 列d("代号")) & Cells(当前行, 列d("名称")) & 行("规格")
            行("编号").WrapText = False
            
            本级数量 = Cells(当前行, 列d("每套数量"))
            至顶级数量 = 本级数量
            a = Split(行("项目号"), ".")
            If a(0) <> "" Then
                '递乘父级
                 For i = UBound(a) - 1 To 0 Step -1
                    父级 = ""
                    For j = i To 0 Step -1
                        父级 = "." & a(j) & 父级
                    Next j
                    父级 = Mid(父级, 2)
                    For m = 表头行 + 1 To 当前行 - 1
                        If Cells(m, 列d("项目号")) = 父级 Then 至顶级数量 = 至顶级数量 * Cells(m, 列d("每套数量")): Exit For
                    Next m
                 Next i
                 '递乘父级
            End If
            Cells(当前行, 列d("至顶级数量")) = 至顶级数量
'        End If
    Next 当前行
    
    Cells(表头行 + 1, 列d("每台数量")).Resize(末行, 1).ClearContents
    Cells(表头行 + 1, 列d("每台数量")).Resize(末行, 1).Interior.ColorIndex = xlNone
    颜色 = 16711680
    Set 编号字典 = CreateObject("Scripting.Dictionary")
    For 当前行 = 表头行 + 1 To 末行
        编号 = 行("编号")
        行("每台数量").Select
        If Not 编号字典.Exists(编号) Then
            Set 编号字典(编号) = CreateObject("Scripting.Dictionary")
            Set 编号字典(编号)("对应行") = CreateObject("Scripting.Dictionary")
        Else
        End If
        总数 = Cells(当前行, 列d("至顶级数量")) + 编号字典(编号)("总数")
        编号字典(编号)("总数") = 总数
        编号字典(编号)("对应行")(当前行) = ""
    Next 当前行
    
    For Each Key In 编号字典.keys
        第几个键 = 0
        For Each 行号 In 编号字典(Key)("对应行").keys
            If 编号字典(Key)("对应行").Count > 1 Then
               第几个键 = 第几个键 + 1
               If 第几个键 = 1 Then
                    第一个键 = 行号
                    Cells(行号, 列d("每台数量")) = 编号字典(Key)("总数")
               Else
                    Cells(行号, 列d("每台数量")).Formula = "=" & Cells(第一个键, 列d("每台数量")).Address(False, False)
               End If
               Cells(行号, 列d("每台数量")).Interior.Color = 颜色
            Else
                Cells(行号, 列d("每台数量")) = 编号字典(Key)("总数")
            End If
        Next
        颜色 = 颜色 - 20000
    Next
'    MsgBox "Done!", vbInformation
End Sub

Sub 规格算材料()
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)
    
    For Each 行 In 表字典.items
        行("规格").Select
        k = 行("规格").Row
        原材料名称 = 行("材料")
        规格 = 行("规格")
        规格 = Replace(规格, " L=", "长")
        
        行("板厚或截面标记").Value = ""
        行("面积或长度").Value = ""
        行("计价单位").Value = ""
        截面 = ""
        
        Address1 = 行("面积或长度").Address(False, False)
        Address2 = 行("每台数量").Address(False, False)
'        规格星号分裂数组 = Split(规格, "*")
        规格星号分裂数组 = Split(规格, "X", -1, 1)
        kk = UBound(规格星号分裂数组)
        
        Select Case True
        Case 含其中之一(规格, "厚|厚度")
            a = Split(规格, "厚")
            厚度 = a(1) & "mm"
            If InStr(1, 规格, "㎡", 1) <> 0 Then
                面积 = Replace(a(0), "㎡", "")
            Else
                b = Split(a(0), "X")
                On Error Resume Next
                面积 = b(0) * b(1) / 1000000
            End If
            行("板厚或截面标记").Value = 厚度
            行("面积或长度").Value = 面积
            行("计价单位").Value = "㎡"
        Case 含其中之一(规格, "长|长度")
            a = Split(规格, "长")
            行("板厚或截面标记").Value = a(0)
            长度 = a(1) / 1000
            行("面积或长度").Value = 长度
           行("计价单位").Value = "m"
        Case 含其中之一(规格, "Φ|?")
            a = Split(规格, "X")
            kk = UBound(a)
            If kk = 1 Then
                截面 = a(0)
                长度 = a(1) / 1000
            ElseIf kk = 2 Then
                截面 = a(0) & "X" & a(1)
                长度 = a(2) / 1000
            End If
            行("板厚或截面标记").Value = 截面
            行("面积或长度").Value = 长度
            行("计价单位").Value = "m"
        Case UBound(规格星号分裂数组) = 2
            厚度 = 规格星号分裂数组(0) & "mm"
            面积 = 规格星号分裂数组(1) * 规格星号分裂数组(2) / 1000000
            
            行("板厚或截面标记").Value = 厚度
            行("面积或长度").Value = 面积
            行("计价单位").Value = "㎡"
        End Select
        If 规格 <> "" Then 行("小计").Formula = "=" & Address1 & "*" & Address2

    Next
    
End Sub
Sub 拆规格选择行()
    
    If ActiveCell.Column <> 列d("规格") Or Selection.Columns.Count > 1 Then
        MsgBox "请选择“规格”列，可以多选行，不可以多选列！"
        Exit Sub
    End If
    Dim 行1%, 行2%
    行1 = Selection.Cells.Row
    For Each c In Selection.Cells
        If c.Interior.ColorIndex <> 15 Then
            当前行 = c.Row
            原材料名称 = 行("原材料名称")
            规格 = c
            Select Case True
            Case 含其中之一(原材料名称, "板材|板")
                If InStr(1, 规格, "㎡", 1) <> 0 Then
                    规格 = Replace(规格, "㎡", "")
                    a = Split(规格, "X")
                    厚度 = a(1)
                    面积 = a(0)
                Else
                    a = Split(c, "X")
                    厚度 = a(2) & "mm"
                    面积 = a(0) * a(1) / 1000000
                End If
                行("板厚或截面标记") = 厚度
                行("面积或长度") = 面积
               行("计价单位") = "㎡"
                行("小计").Formula = "=" & 行("面积或长度").Address(False, False) & "*" & 行("每台数量").Address(False, False)
'                行("小计") = 面积 * 行("每台数量")
'                 Cells(行号, 列d("每台数量")).Formula = "=" & Cells(第一个键, 列d("每台数量")).Address(False, False)
            Case 原材料名称 <> ""
                a = Split(规格, "-")
                行("板厚或截面标记") = a(0)
                长度 = a(1) / 1000
                行("面积或长度") = 长度
               行("计价单位") = "m"
'                行("小计") = 长度 * 行("每台数量")
                行("小计").Formula = "=" & 行("面积或长度").Address(False, False) & "*" & 行("每台数量").Address(False, False)
            End Select
'            Dim oRegExp As Object
'            Dim oMatches As Object
'            Dim oMatche As Object
'            Dim sText As String
'            sText = c
'            Set oRegExp = CreateObject("vbscript.regexp")
'            With oRegExp
'    '            .Global = True
'                .IgnoreCase = True
'                .Pattern = "([^\u4e00-\u9fa5\[【]+)[\[【]?([\u4e00-\u9fa5])([^\]】]+)"
'    '            Debug.Print .Test(sText)
'                If .Test(sText) Then
'                    Set oMatches = .Execute(sText)
'                    Debug.Print oMatches(0).submatches(0)
'                    Cells(c.Row, 代号列) = oMatches(0).submatches(0)
'                    Cells(c.Row, 名称列) = oMatches(0).submatches(1) & oMatches(0).submatches(2)
'                Else: MsgBox "拆不了，请自己拆！"
'                End If
'            End With
'            Set oRegExp = Nothing
'            Set oMatches = Nothing
            行2 = c.Row
        End If
    Next
    Range(Cells(行1, 列d("小计")), Cells(行2, 列d("小计"))).Select
    
End Sub
Sub 拆文件名()
    If ActiveCell.Column <> 文件名称列 Or Selection.Columns.Count > 1 Then
        MsgBox "请选择“文件名称列”列，可以多选行，不可以多选列！"
        Exit Sub
    End If
    Dim 行1%, 行2%
    行1 = Selection.Cells.Row
    For Each c In Selection.Cells
        If c.Interior.ColorIndex <> 15 Then
            Dim oRegExp As Object
            Dim oMatches As Object
            Dim oMatche As Object
            Dim sText As String
            sText = c
            Set oRegExp = CreateObject("vbscript.regexp")
            With oRegExp
    '            .Global = True
                .IgnoreCase = True
                .Pattern = "([^\u4e00-\u9fa5\[【]+)[\[【]?([\u4e00-\u9fa5])([^\]】]+)"
    '            Debug.Print .Test(sText)
                If .test(sText) Then
                    Set oMatches = .Execute(sText)
                    Debug.Print oMatches(0).submatches(0)
                    Cells(c.Row, 代号列) = oMatches(0).submatches(0)
                    Cells(c.Row, 名称列) = oMatches(0).submatches(1) & oMatches(0).submatches(2)
                Else: MsgBox "拆不了，请自己拆！"
                End If
            End With
            Set oRegExp = Nothing
            Set oMatches = Nothing
            行2 = c.Row
        End If
    Next
    Range(Cells(行1, 代号列), Cells(行2, 名称列)).Select
End Sub

Sub 下料尺寸到规格()
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)
    
    For Each 行 In 表字典.items
        If 行("规格").Value = "" Then
                Debug.Print 行("规格").Row
                下料尺寸 = 行("下料尺寸").Value
                Debug.Print 下料尺寸
                下料尺寸 = Replace(下料尺寸, "x", "X")
                Debug.Print 下料尺寸
                
                Debug.Print Len(下料尺寸) - 1
                最末字符 = UCase(Right(下料尺寸, 1))
                If 最末字符 = "X" Then
                    Debug.Print 下料尺寸
                    Debug.Print Len(下料尺寸) - 1
'                    下料尺寸 = Mid(下料尺寸, Len(下料尺寸) - 1)'???为什么不行
                    下料尺寸 = Left(下料尺寸, Len(下料尺寸) - 1)
                End If
                
                If InStr(1, 下料尺寸, "*", 1) <> 0 And InStr(1, 下料尺寸, "X", 1) <> 0 Then
                    下料尺寸 = Replace(下料尺寸, "X", "长")
                End If
                
                行("规格").Value = 下料尺寸
        End If
    Next

End Sub

Sub 原材料汇总()
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)
    
    Set 原材料分项字典 = CreateObject("Scripting.Dictionary")
    Set 原材料编号字典 = CreateObject("Scripting.Dictionary")
    Set 原材料汇总用字典 = CreateObject("Scripting.Dictionary")
    键 = 1
    For Each 行 In 表字典.items
        行("原材料编号").Select
        If 行("板厚或截面标记") <> "" Then
            原材料分项字典.Add 键, 行
            键 = 键 + 1
            '开始给原材料编号
            行("原材料编号").Value = 行("材料") & 行("板厚或截面标记")
            行("原材料编号").WrapText = False
            原材料编号 = 行("原材料编号")
            
            If Not 原材料汇总用字典.Exists(原材料编号) Then
                Set 原材料汇总用字典(原材料编号) = CreateObject("Scripting.Dictionary")
                Set 原材料汇总用字典(原材料编号)("对应行") = CreateObject("Scripting.Dictionary")
                原材料汇总用字典(原材料编号)("对应行键") = 1
                原材料汇总用字典(原材料编号)("父编号") = 行("编号")
                原材料编号字典.Add 原材料编号, 行
            Else
                原材料汇总用字典(原材料编号)("对应行键") = 原材料汇总用字典(原材料编号)("对应行键") + 1
            End If
            
            If 原材料汇总用字典(原材料编号)("父编号") <> 行("编号") Then
                原材料汇总用字典(原材料编号)("原材料总计") = 行("小计") + 原材料汇总用字典(原材料编号)("原材料总计")
            Else
                原材料汇总用字典(原材料编号)("原材料总计") = 行("小计")
            End If
            原材料汇总用字典(原材料编号)("对应行").Add 原材料汇总用字典(原材料编号)("对应行键"), 行
        End If
    
    Next

    表字典(表头行 + 1)("原材料总计").Resize(末行, 1).ClearContents
    表字典(表头行 + 1)("原材料总计").Resize(末行, 1).Interior.ColorIndex = xlNone
    颜色 = 16711680
    For Each Key In 原材料汇总用字典.keys
        Set 第一个行 = 原材料汇总用字典(Key)("对应行")(1)
        For Each 对应行Key In 原材料汇总用字典(Key)("对应行").keys
            Set 行 = 原材料汇总用字典(Key)("对应行")(对应行Key)
            行("原材料总计").Select
            If 原材料汇总用字典(Key)("对应行").Count > 1 Then
               If 对应行Key = 1 Then
                    行("原材料总计").Value = 原材料汇总用字典(Key)("原材料总计")
               Else
                    行("原材料总计").Formula = "=" & 第一个行("原材料总计").Address(False, False)
               End If
               行("原材料总计").Interior.Color = 颜色
            Else
                行("原材料总计").Value = 原材料汇总用字典(Key)("原材料总计")
            End If
        Next
        颜色 = 颜色 - 20000
    Next
    
    '粘贴会切换表格，注意最后再粘贴字典
    kk = 原材料汇总用字典.Count
    Call 粘贴字典(原材料编号字典, "原材料汇总表", "B2")
    Call 粘贴字典(原材料分项字典, "原材料分项表", "A2")
End Sub

Sub 其他汇总()
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)

    Set 已有编号字典 = CreateObject("Scripting.Dictionary")
    Set 加工字典 = CreateObject("Scripting.Dictionary")
    Set 外购字典 = CreateObject("Scripting.Dictionary")
    Set 企标字典 = CreateObject("Scripting.Dictionary")
    Set 激光下料字典 = CreateObject("Scripting.Dictionary")
    Set 图纸下发清单字典 = CreateObject("Scripting.Dictionary")
    
    For Each k In 表字典.keys
        Set 行 = 表字典(k)
        编号值 = 行("编号").Value
        代号去空格 = Replace(行("代号").Value, " ", "")
        名称去空格 = Replace(行("名称").Value, " ", "")
        If Not 已有编号字典.Exists(编号值) Then
            类别 = 行("类别")
            If 含其中之一(类别, "外购且机加件|外购并机加件|外购定制") Then
                外购字典.Add k, 行
                加工字典.Add k, 行
            ElseIf 含其中之一(类别, "标准件|国标件") Then
                外购字典.Add k, 行
            ElseIf 含其中之一(类别, "外购件|外购") Then
                外购字典.Add k, 行
            ElseIf 含其中之一(类别, "厂标件|企标件") Then
                企标字典.Add k, 行
            Else
                If 名称去空格 <> "" Then
                    If 含其中之一(行("规格"), "*|x|X|长") Then
'                        外购字典.Add k, 行
                    ElseIf Not 在列表中(行("名称"), Range("外购件黑名单").Value) Then
                        If 含其中之一V2(行("名称"), Range("外购件名称关键词").Value) Then
                            外购字典.Add k, 行
                        End If
                    End If
                    
                    If Not 在列表中(行("名称"), Range("加工件黑名单").Value) Then
'                        If 在列表中(行("名称"), Range("加工件白名单").Value) Then
                            加工字典.Add k, 行
'                        ElseIf Not 含其中之一V2(行("名称"), Range("外购件名称关键词").Value) Then
'                            加工字典.Add k, 行
'                        End If
                    End If
                End If
            End If
            
            If 含其中之一(行("备注"), "激光下料|激光") Then
                激光下料字典.Add k, 行
            End If
            
            If Not 含其中之一(行("备注"), "无图|国标件|标准件") And Not (含其中之一(行("类别"), "无图|国标件|标准件")) _
            And 代号去空格 <> "" And Not (含其中之一(行("代号"), "无图|国标件|标准件|图样代号|gb|jb")) Then
                图纸下发清单字典.Add k, 行
            End If
            已有编号字典.Add 编号值, ""
        End If
    Next

    Call 粘贴字典(表字典, "BOM清单", "A2")
    Call 粘贴字典(加工字典, "加工件汇总表", "B2")
    Call 粘贴字典(外购字典, "外购件及标准件汇总表", "B2")
    Call 粘贴字典(企标字典, "企标件汇总表", "B2")
'    Call 粘贴字典(激光下料字典, "激光下料汇总表", "B2")
'    Call 粘贴字典(图纸下发清单字典, "图纸下发清单", "B3")
End Sub

Sub cs()
    yy = Array("jj", "dd")
    Debug.Print Join(yy, "|")
'    Debug.Print Join(Range("加工件黑名单").Value, "|")
    For Each kk In Range("加工件黑名单").Value
        Debug.Print kk
    Next
End Sub
Sub cs2()
'    Debug.Print 在列表中("地脚", Range("加工件黑名单").Value)
'    Debug.Print 在列表中("地脚组装", Range("加工件黑名单").Value)
    
'    Debug.Print 在列表中("地脚组装", Range("加工件白名单").Value)
     Debug.Print 在列表中("地脚", Range("外购件黑名单").Value)
End Sub

Sub 导出()
    sw全名 = Range("装配体")
    Call 拆分文件名(sw全名)
    
    导出路径 = FilePath
    后缀 = "=" & Format(Date, "yymmdd") & "." & Format(Time, "hhmmss")
    导出名称 = Range("顶层代号") & Range("顶层名称") & " " & "BOM清单" & 后缀 & ".xlsx"
    图纸清单名称 = Range("顶层代号") & Range("顶层名称") & " " & "图纸下发清单" & 后缀 & ".xlsx"
    
    Sheets("BOM清单").Visible = True
    Sheets("BOM清单").Copy
    
    ActiveWorkbook.SaveAs Filename:=导出路径 & 导出名称
    导出表名 = ActiveWorkbook.Name
    
    Sheet1.Activate
    Sheets("BOM清单").Visible = False

'    导出表组 = Array("原材料分项表", "原材料汇总表", "外购件及标准件汇总表", "企标件汇总表", "激光下料汇总表")
    导出表组 = Array("原材料分项表", "原材料汇总表", "加工件汇总表", "外购件及标准件汇总表")
    For i = 0 To UBound(导出表组)
        Sheet1.Activate
        Sheets(导出表组(i)).Copy After:=Workbooks(导出表名).Sheets(i + 1)
    Next
'    Sheet1.Activate
'    Sheets("原材料分项表").Copy After:=Workbooks(导出表名).Sheets(1)
'
'    Sheet1.Activate
'    Sheets("原材料汇总表").Copy After:=Workbooks(导出表名).Sheets(2)
'
'    Sheet1.Activate
'    Sheets("外购件及标准件汇总表").Copy After:=Workbooks(导出表名).Sheets(3)
'
'    Sheet1.Activate
'    Sheets("企标件汇总表").Copy After:=Workbooks(导出表名).Sheets(4)

    Sheet1.Activate
    Cells.Copy
    Sheets("层次BOM原始数据备份").Range("A1").PasteSpecial Paste:=xlPasteAll
    Sheets("层次BOM原始数据备份").Copy After:=Workbooks(导出表名).Sheets(i + 1)
    Sheets("BOM清单").Activate
    Workbooks(导出表名).Save
    
'    Sheet1.Activate
'    Sheets("图纸下发清单").Copy
'    ActiveWorkbook.SaveAs Filename:=导出路径 & 图纸清单名称
    
End Sub
Sub 另存()
    sw全名 = Range("装配体")
    Call 拆分文件名(sw全名)
    
    导出路径 = FilePath
    后缀 = "=" & Format(Date, "yymmdd") & "." & Format(Time, "hhmmss")
    导出名称 = Range("顶层代号") & Range("顶层名称") & "=" & "BOM层次及汇总表" & 后缀 & ".xlsm"
    
    ActiveWorkbook.SaveCopyAs Filename:=导出路径 & 导出名称
'    Workbooks.Open 导出路径 & 导出名称

End Sub

Sub 导出f()
    Range("层次BOM标题").MergeCells = False
    
    Sheet1.Activate
    Cells.Copy
    Sheets("BOM清单").Range("A1").PasteSpecial Paste:=xlPasteAll
    
    Sheets("BOM清单").Activate
    Range("层次BOM标题").ClearContents
    With Range("层次BOM标题")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
        .Font.Size = 14
        .Font.Bold = True
    End With
    Range("层次BOM标题") = "<<" & Range("顶层代号") & Range("顶层名称") & ">> BOM清单"

    Columns("J:T").Select
    Selection.EntireColumn.Hidden = True
'    Rows("2:2").EntireRow.AutoFit
    Rows("2:2").RowHeight = 26

    Cells.Select
    With Selection.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    Selection.Interior.Pattern = xlNone

    
End Sub