第二步，就是要将拆分好的任务导入ERP了
1、将建一个BOS单据叫“任务池”，大概是这样的
然后在拆分工具中进行导数据，点击“数据导出准备”，跳转到“导入ERP”界面，然后点“获取数据”，将拆分好的数据转过来
代码如下：
''获取任务Sub list()
Dim rng1 As Range
Dim sRowsCount As Long, sColnumb As Long, tRowsCount As Long, tColnumb As Long
Dim itemnumb As String
Dim i As Integer, j As Integer, k As Integer, ZJsl As Integer
Dim jcbh As String, ZJnumb As String, ZJitemid As String, Fitemid As String, fnumber As String
Dim ARR
Dim tRNG As RangeApplication.ScreenUpdating = False '关闭屏幕更新，加快程序运行
ActiveSheet.Unprotect Password:="chr"Worksheets("母版").Activate
sRowsCount = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row '行数按物料代码行计算'
'For i = 8 To sRowsCount
'
' MsgBox IsComponents(Trim(Cells(i, 2)))
'NextWith ActiveSheet
jcbh = Trim(.Cells(4, 6)) '机床编号
ZJnumb = Trim(.Cells(3, 4)) '组件代码
ZJitemid = Trim(.Cells(3, 10)) '组件的itemid
ZJsl = Trim(.Cells(5, 4)) '组件数量ReDim ARR(1 To sRowsCount - 7, 1 To 11)
i = 0
j = 0
k = 0
For i = 1 To UBound(ARR)
' For j = 8 To sRowsCountj = i + 7 '取母版中的实际行数
''物料代码规则中第三个点后第1个数字是1则为组部件，用以排除
If IsComponents(Trim(.Cells(j, 2).Value)) <> 1 Then
When34:ARR(i, 1) = jcbhARR(i, 3) = ZJnumbARR(i, 2) = ZJitemidARR(i, 4) = Trim(.Cells(j, 10).Value) '获取零件的itemidARR(i, 5) = Trim(.Cells(j, 2).Value) '获取零件的代码ARR(i, 6) = Trim(.Cells(j, 5).Value) * ZJsl '获取零件的数量''获取采购、外协、机加的计划完工日期If Not IsEmpty(Cells(j, 13).Value) Then '采购ARR(i, 7) = 26370ARR(i, 8) = Trim(.Cells(j, 13).Value)End IfIf Not IsEmpty(Cells(j, 14).Value) Then '外协ARR(i, 7) = 84761ARR(i, 8) = Trim(.Cells(j, 14).Value)End IfIf Not IsEmpty(Cells(j, 15).Value) Then '新核交畅尔入库的实质是采购任务ARR(i, 7) = 26370ARR(i, 8) = Trim(.Cells(j, 15).Value)End IfIf Not IsEmpty(Cells(j, 16).Value) Then '机加ARR(i, 7) = 54492ARR(i, 8) = Trim(.Cells(j, 16).Value)End IfIf Not IsEmpty(Cells(j, 17).Value) Then '仓库ARR(i, 7) = 53681ARR(i, 8) = Trim(.Cells(j, 17).Value)End If''获取铸件、新核日期If Trim(.Cells(j, 15).Value) <> "" ThenIf Trim(.Cells(j, 16).Value) <> "" Then '判断如果没有机加日期，则是交畅尔的任务，应该算是采购ARR(i, 9) = 84046End IfARR(i, 10) = Trim(.Cells(j, 15).Value)End IfIf Mid(Trim(.Cells(j, 6).Value), 1, 1) = 5 ThenARR(i, 9) = 84048ARR(i, 10) = Trim(.Cells(j, 13).Value)End IfARR(i, 11) = Trim(.Cells(j, 8).Value) '获取备注内容ElseIf (Mid(Trim(.Cells(j, 2).Value), 1, 1) = "3" Or Mid(Trim(.Cells(j, 2).Value), 1, 1) = "4") ThenGoTo When34End If
Next
End WithWorksheets("导入ERP").Activate
tRowsCount = UBound(ARR, 1)
tColnumb = UBound(ARR, 2)Worksheets("导入ERP").Range("A2").Select
Set tRNG = Selection.Resize(tRowsCount, tColnumb)tRNG.Value = ARR'重新获取行数，以物料内码列为准
tRowsCount = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Rowj = 0
For i = 2 To tRowsCountRange("M" & i).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-6],R2C27:R10C28,2,),"""")"
Range("N" & i).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-5],R2C27:R10C28,2,),"""")"'
'If IsEmpty(Cells(i, 4).Value) Then
'j = j + 1
'End IfIf IsEmpty(Cells(i, 1).Value) Then
Range("A" & i & ":N" & i).Select
Selection.Delete Shift:=xlUp
End IfNextCall moformat.form(2)ActiveSheet.Columns("A:Z").Locked = False
ActiveSheet.Range("A1:K1").Locked = True
ActiveSheet.Protect Password:="chr", AllowFormattingColumns:=True, AllowSorting:=True, AllowFiltering:=True, UserInterFaceOnly:=True ''增加保护：
Application.DisplayAlerts = TrueEnd Sub
''获取物料代码第3个.之后第1个数字是否为1，用以排除组部件
Function IsComponents(fnumber As String) As Integer
Dim numb As Integer, i As Integer, j As Integer
Dim point As Stringj = 0
For i = 1 To Len(fnumber)
If Mid(fnumber, i, 1) = "." Then
j = j + 1If j = 3 Thennumb = Mid(fnumber, i + 1, 1)End IfEnd IfNextIsComponents = numbEnd Function即将导入数据库的信息，有很多已转换成内码，点击“导入ERP任务”，则会将数据导入到ERP中。
在ERP中的任务池表中就有了数据
代码如下：
Sub Import()Dim objRec
Dim objConn
Dim rowscount As Long
Dim rng As Range
Dim i As Integer, j As Integer
Dim finterid As Long
Dim fbillno As String
Dim sqlStr As StringWorksheets("导入ERP").Activate
rowscount = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row '按物料内码算行数If Len(ActiveSheet.Cells(1, 27)) > 0 ThenMsgBox "导入ERP已执行，请查看！", , "BuildByWK"
Exit SubElse'先检查物料内码有没有空的
For i = 2 To rowscount
If IsEmpty(Cells(i, 4).Value) Then
j = j + 1
End If
NextIf j > 0 Then
MsgBox "有物料内码为空，请查看是否为组件或是物料不存在!", , "BuildByWK"
Exit Sub
End IfSet rng = ActiveSheet.Range("A2:K" & rowscount) '设置需要的数据范围Set objRec = CreateObject("ADODB.Recordset")
Set objConn = CreateObject("ADODB.Connection")objConn.ConnectionString = "Provider=SQLOLEDB;Data Source=192.168.100.3;Initial Catalog=AIS20150813141843;User ID=sa;Password=Chr_2016"On Error GoTo Erro
objConn.Open''获取任务池单据最大的内码
sqlStr = "SELECT FMaxNum FROM ICMaxNum where FTableName='t_BOS257800039'"Set objRec = objConn.Execute(sqlStr)
If Not objRec.EOF Thenfinterid = objRec.Fields("FMaxNum").Value
End If
sqlStr = ""''获取任务池单据最大的单据编号
sqlStr = "select FDesc from ICBillNo where FBillID=257800039"
Set objRec = objConn.Execute(sqlStr)
If Not objRec.EOF Thenfbillno = objRec.Fields("FDesc").Value
End If
sqlStr = ""''将内码和单据编号都加1赋给插入的单据
finterid = finterid + 1
fbillno = format(CLng(fbillno) + 1, "000000000")'''将内码和单据编号插入表头
sqlStr = "INSERT INTO t_BOS257800039 (fid,FClassTypeID,FBillNo,FDate) VALUES (" & finterid & ", " & 257800039 & ",'" & fbillno & "','" & Now & "')"
objConn.Execute sqlStr
sqlStr = ""'将内容插入表体For Each Row In rng.Rows
sqlStr = "INSERT INTO t_BOS257800039Entry2 (FID,FIndex,JCBH,ZJitemID,FitemID,Fquantity,FBase2,FPlanDate,FOutsource,FOutDate,FNOTE,FComboBOX) VALUES " _& "( '" & finterid & "','" & Row.Row - 1 & "','" & Row.Cells(1).Value & "'," _& " '" & Row.Cells(2).Value & " ','" & Row.Cells(4).Value & "','" & Row.Cells(6).Value & "','" & Row.Cells(7).Value & "'," _& " '" & Row.Cells(8).Value & " ','" & Row.Cells(9).Value & "','" & Row.Cells(10).Value & " ','" & Row.Cells(11).Value & "',0)"objConn.Execute sqlStr
sqlStr = ""
Next Row''更新任务池单据内码
sqlStr = "update ICBillNo set FDesc='" & fbillno & "' where FBillID=257800039"
objConn.Execute sqlStr
sqlStr = ""''更新任务池单据编号
sqlStr = "update ICMaxNum set FMaxNum=" & finterid & "where FTableName='t_BOS257800039'"
objConn.Execute sqlStr
sqlStr = ""'关闭记录集和连接
objRec.Close
objConn.Close'释放对象
Set objRec = Nothing
Set objConn = NothingActiveSheet.Cells(1, 27) = Now()
MsgBox "数据导入完成！单据编号为：" & fbillno, , "BuildByWK"End IfExit Sub
Erro:MsgBox "连接失败:" & Err.Description, vbCriticalIf Not objConn Is noting ThenobjConn.CloseEnd IfSet objConn = NothingEnd Sub另外，为了方便留底，还能将拆分的表格另存出来
代码如下：
Sub SaveAsDialog()Dim savePath As StringDim FName As StringDim fileFilter As StringDim ws As WorksheetDim newWB As Workbook' 定义初始文件名和文件过滤器With ThisWorkbook.Sheets("母版")FName = Trim(.Cells(3, 4)) & "_" & Trim(.Cells(4, 4)) & "(" & Trim(.Cells(4, 6)) & ")" & ".xlsx"fileFilter = "Excel Files (*.xlsx), *.xlsx" ' 文件过滤器End With' 调用 GetSaveAsFilename 方法savePath = Application.GetSaveAsFilename(initialFileName:=FName, fileFilter:=fileFilter)
Application.DisplayAlerts = False '不显示警告信息' 设置要复制的工作表Set ws = ThisWorkbook.Sheets("母版") ' 修改为你的工作表名称' 复制工作表到新工作簿ws.Copy' 设置新工作簿的引用Set newWB = ActiveWorkbook' 检查用户是否选择了文件并点击了“保存”On Error Resume NextIf savePath <> "" Then
' ' 保存工作簿到用户选定的位置
'' ThisWorkbook.SaveAs FileName:=savePath, _newWB.SaveAs FileName:=savePath, _FileFormat:=xlOpenXMLWorkbook ' xlOpenXMLWorkbook 表示Excel 2007及以后版本的文件格式MsgBox "文件已保存到: " & savePathElseMsgBox "没有选择文件或取消操作。"End IfApplication.DisplayAlerts = True
End Sub'
