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