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 SubModule1格式化项目号
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模块1sw初始化_通用
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模块1含其中之一jia在列表中
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模块1粘贴字典
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模块2算每台数量
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模块30规格算材料
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模块31下料尺寸到规格
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模块33原材料汇总
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模块41其他汇总
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模块5导出jia另存
本文章为转载内容，我们尊重原作者对文章享有的著作权。如有内容错误或侵权问题，欢迎原作者联系我们进行内容更正或删除文章。
