Option Compare Database
'按批次分配
Private Sub Command0_Click()
'ADO连接数据库
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim strSQL As String
Dim name As String, pass As String
'复制库存表做临时表
On Error Resume Next
strSQL = "select top 1 from Inventorytemp"
rs.Open strSQL, CurrentProject.AccessConnection
If (Err) Then
'临时表不存在，复制库存表到临时表
DoCmd.SetWarnings False
strSQL = "select * into Inventorytemp from [Inventory-raw]"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Else
'先删除临时表再复制表到临时表
DoCmd.SetWarnings False
strSQL = "drop table [Inventory-raw]"
DoCmd.RunSQL strSQL
strSQL = "select * into Inventorytemp from [Inventory-raw]"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
On Error GoTo 0
'清空配货报告明细表
strSQL = "delete * from [SO Allocation-BY LOT] "
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
'读取so type配置表
Dim sortrs As ADODB.Recordset
Set sortrs = New ADODB.Recordset
Dim sortorder As String
sortorder = ""
strSQL = "select * from [orderstatus] order by id"
sortrs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If sortrs.EOF Then
'MsgBox "请检查排序配置表!"
Else
'sortorder = sortorder + " [Ship to]"
Dim count As Integer
Dim laststr As String
laststr = "999999)"
count = 1
Do While Not sortrs.EOF
sortorder = sortorder + " IIf ([Order Status] ='" & sortrs("Order Status") & "'," & sortrs("id") & ","
If count = sortrs.RecordCount Then
sortorder = sortorder + laststr
Else
laststr = laststr + ")"
count = count + 1
End If
sortrs.MoveNext
Loop
End If
sortrs.Close
'读取ship to 配置
Dim shiptors As ADODB.Recordset
Set shiptors = New ADODB.Recordset
Dim sortshipto As String
sortshipto = ""
strSQL = "select * from [shipto] order by id"
shiptors.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If shiptors.EOF Then
'MsgBox "请检查排序配置表!"
Else
Dim count2 As Integer
Dim laststr2 As String
laststr2 = "999999)"
count2 = 1
Do While Not shiptors.EOF
sortshipto = sortshipto + " IIf ([Ship To] =" & shiptors("Ship To") & "," & shiptors("id") & ","
If count2 = shiptors.RecordCount Then
sortshipto = sortshipto + laststr2
Else
laststr2 = laststr2 + ")"
count2 = count2 + 1
End If
shiptors.MoveNext
Loop
End If
shiptors.Close
strSQL = "select * from [SO Backlog Report-raw]" + " order by " + sortorder + "," + sortshipto + ", [Order Number] ,[Line Number]"
rs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If rs.EOF Then
MsgBox "请检查源数据！"
Else
'读取ship to 配置[Location Number]
Dim Locationrs As ADODB.Recordset
Set Locationrs = New ADODB.Recordset
Dim sortLocation As String
sortLocation = ""
strSQL = "select * from [LocationNumber] order by id"
Locationrs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If Locationrs.EOF Then
'MsgBox "请检查排序配置表!"
Else
Dim count3 As Integer
Dim laststr3 As String
laststr3 = "999999)"
count3 = 1
Do While Not Locationrs.EOF
sortLocation = sortLocation + " IIf ([Location Number] ='" & Locationrs("Location Number") & "'," & Locationrs("id") & ","
If count3 = Locationrs.RecordCount Then
sortLocation = sortLocation + laststr3
Else
laststr3 = laststr3 + ")"
count3 = count3 + 1
End If
Locationrs.MoveNext
Loop
End If
Locationrs.Close
'循环订单插入配货报告明细
Do While Not rs.EOF
'MsgBox "'" & rs("ordernumber") & "'"
Dim Inrs As ADODB.Recordset
Set Inrs = New ADODB.Recordset
strSQL = "select * from [Inventorytemp] where [Item Number]='" & rs("2nd Item Number") & "' and [Purchasing Qty]>0" + " order by " + sortLocation
Inrs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If Inrs.EOF Then
'向配货报告明细插一条数据（对应的库存信息空着）
strSQL = "INSERT INTO [SO Allocation-BY LOT]([BU],[Order Status],[SUB BU],[Or Date Ty],[Order Number],[Or Ty],[Line Number],[2nd Item Number],[Quantity],[UOM],[Unit Price],"
strSQL = strSQL + "[Total Amount],[Extended Amount],[Quantity Shipped],[Quantity Backordered],[Branch/Plant],[Location],[Lot Serial Number],[Last Status],[Next Status],[Pick Number]"
strSQL = strSQL + ",[Document Number],[Doc Ty],[Invoice Date],[Ship To Description],[Ship To],[Sold To],[Customer PO],[Description 1],[Order Date],[Request Date],[Price Effective Date]"
strSQL = strSQL + ",[Branch/Plant2],[Location2],[Lot Serial Number2],[可配货数量],[可配货金额])"
strSQL = strSQL + " values('" & rs("bu") & "','" & rs("Order Status") & "','" & rs("SUB BU") & "','" & rs("Or Date Ty") & "','" & rs("Order Number") & "','" & rs("Or Ty") & "'"
strSQL = strSQL + ",'" & rs("Line Number") & "','" & rs("2nd Item Number") & "','" & rs("Quantity") & "','" & rs("UOM") & "','" & rs("Unit Price") & "','" & rs("Total Amount") & "'"
strSQL = strSQL + ",'" & rs("Extended Amount") & "','" & rs("Quantity Shipped") & "','" & rs("Quantity Backordered") & "','" & rs("Branch/Plant") & "','" & rs("Location") & "'"
strSQL = strSQL + ",'" & rs("Lot Serial Number") & "','" & rs("Last Status") & "','" & rs("Next Status") & "','" & rs("Pick Number") & "'"
strSQL = strSQL + ",'" & rs("Document Number") & "','" & rs("Doc Ty") & "','" & rs("Invoice Date") & "','" & Replace(rs("Ship To Description"), "'", " ") & "','" & rs("Ship To") & "'"
strSQL = strSQL + ",'" & rs("Sold To") & "','" & rs("Customer PO") & "','" & Replace(rs("Description 1"), "'", " ") & "','" & rs("Order Date") & "','" & rs("Request Date") & "','" & rs("Price Effective Date") & "'"
strSQL = strSQL + ",null,null,null,0,0)"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Else
Dim num As Integer
num = 0
Do While Not Inrs.EOF
If (num >= rs("Quantity")) Then
Exit Do
Else
If (Inrs("Purchasing Qty") + num >= rs("Quantity")) Then
strSQL = "INSERT INTO [SO Allocation-BY LOT]([BU],[Order Status],[SUB BU],[Or Date Ty],[Order Number],[Or Ty],[Line Number],[2nd Item Number],[Quantity],[UOM],[Unit Price],"
strSQL = strSQL + "[Total Amount],[Extended Amount],[Quantity Shipped],[Quantity Backordered],[Branch/Plant],[Location],[Lot Serial Number],[Last Status],[Next Status],[Pick Number]"
strSQL = strSQL + ",[Document Number],[Doc Ty],[Invoice Date],[Ship To Description],[Ship To],[Sold To],[Customer PO],[Description 1],[Order Date],[Request Date],[Price Effective Date]"
strSQL = strSQL + ",[Branch/Plant2],[Location2],[Lot Serial Number2],[可配货数量],[可配货金额])"
strSQL = strSQL + " values('" & rs("bu") & "','" & rs("Order Status") & "','" & rs("SUB BU") & "','" & rs("Or Date Ty") & "','" & rs("Order Number") & "','" & rs("Or Ty") & "'"
strSQL = strSQL + ",'" & rs("Line Number") & "','" & rs("2nd Item Number") & "','" & rs("Quantity") & "','" & rs("UOM") & "','" & rs("Unit Price") & "','" & rs("Total Amount") & "'"
strSQL = strSQL + ",'" & rs("Extended Amount") & "','" & rs("Quantity Shipped") & "','" & rs("Quantity Backordered") & "','" & rs("Branch/Plant") & "','" & rs("Location") & "'"
strSQL = strSQL + ",'" & rs("Lot Serial Number") & "','" & rs("Last Status") & "','" & rs("Next Status") & "','" & rs("Pick Number") & "'"
strSQL = strSQL + ",'" & rs("Document Number") & "','" & rs("Doc Ty") & "','" & rs("Invoice Date") & "','" & Replace(rs("Ship To Description"), "'", " ") & "','" & rs("Ship To") & "'"
strSQL = strSQL + ",'" & rs("Sold To") & "','" & rs("Customer PO") & "','" & Replace(rs("Description 1"), "'", " ") & "','" & rs("Order Date") & "','" & rs("Request Date") & "','" & rs("Price Effective Date") & "'"
strSQL = strSQL + ",'" & Inrs("B/P#") & "','" & Inrs("Location Number") & "','" & Inrs("Lot Number") & "','" & rs("Quantity") - num & "','" & (rs("Quantity") - num) * Inrs("SBJ DNP ") & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
'更新库存
Dim aaa As Single
aaa = (rs("Quantity") - num) * Inrs("SBJ DNP ")
strSQL = "update [Inventorytemp] set [Purchasing Qty]=" & Inrs("Purchasing Qty") - rs("Quantity") + num & ",[Purchasing Stock Value(DNP)]=" & Inrs("Purchasing Stock Value(DNP)") - aaa & " where [B/P#]=" & Inrs("B/P#") & " and [Location Number]='" & Inrs("Location Number") & "'"
strSQL = strSQL + " and [Item Number]='" & Inrs("Item Number") & "' and [Purchasing Qty]=" & Inrs("Purchasing Qty") & " and [Purchasing Stock Value(DNP)]=" & Inrs("Purchasing Stock Value(DNP)") & ""
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
num = num + (rs("Quantity") - num)
Else
strSQL = "INSERT INTO [SO Allocation-BY LOT]([BU],[Order Status],[SUB BU],[Or Date Ty],[Order Number],[Or Ty],[Line Number],[2nd Item Number],[Quantity],[UOM],[Unit Price],"
strSQL = strSQL + "[Total Amount],[Extended Amount],[Quantity Shipped],[Quantity Backordered],[Branch/Plant],[Location],[Lot Serial Number],[Last Status],[Next Status],[Pick Number]"
strSQL = strSQL + ",[Document Number],[Doc Ty],[Invoice Date],[Ship To Description],[Ship To],[Sold To],[Customer PO],[Description 1],[Order Date],[Request Date],[Price Effective Date]"
strSQL = strSQL + ",[Branch/Plant2],[Location2],[Lot Serial Number2],[可配货数量],[可配货金额])"
strSQL = strSQL + " values('" & rs("bu") & "','" & rs("Order Status") & "','" & rs("SUB BU") & "','" & rs("Or Date Ty") & "','" & rs("Order Number") & "','" & rs("Or Ty") & "'"
strSQL = strSQL + ",'" & rs("Line Number") & "','" & rs("2nd Item Number") & "','" & rs("Quantity") & "','" & rs("UOM") & "','" & rs("Unit Price") & "','" & rs("Total Amount") & "'"
strSQL = strSQL + ",'" & rs("Extended Amount") & "','" & rs("Quantity Shipped") & "','" & rs("Quantity Backordered") & "','" & rs("Branch/Plant") & "','" & rs("Location") & "'"
strSQL = strSQL + ",'" & rs("Lot Serial Number") & "','" & rs("Last Status") & "','" & rs("Next Status") & "','" & rs("Pick Number") & "'"
strSQL = strSQL + ",'" & rs("Document Number") & "','" & rs("Doc Ty") & "','" & rs("Invoice Date") & "','" & Replace(rs("Ship To Description"), "'", " ") & "','" & rs("Ship To") & "'"
strSQL = strSQL + ",'" & rs("Sold To") & "','" & rs("Customer PO") & "','" & Replace(rs("Description 1"), "'", " ") & "','" & rs("Order Date") & "','" & rs("Request Date") & "','" & rs("Price Effective Date") & "'"
strSQL = strSQL + ",'" & Inrs("B/P#") & "','" & Inrs("Location Number") & "','" & Inrs("Lot Number") & "','" & Inrs("Purchasing Qty") & "','" & Inrs("Purchasing Stock Value(DNP)") & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
'更新库存
strSQL = "update [Inventorytemp] set [Purchasing Qty]=0,[Purchasing Stock Value(DNP)]=0 where [B/P#]=" & Inrs("B/P#") & " and [Location Number]='" & Inrs("Location Number") & "'"
strSQL = strSQL + " and [Item Number]='" & Inrs("Item Number") & "' and [Purchasing Qty]=" & Inrs("Purchasing Qty") & " and [Purchasing Stock Value(DNP)]=" & Inrs("Purchasing Stock Value(DNP)") & ""
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
num = num + Inrs("Purchasing Qty")
End If
End If
Inrs.MoveNext
Loop
End If
rs.MoveNext
Loop
End If
Inrs.Close
rs.Close
'打开表
DoCmd.OpenTable "SO Allocation-BY LOT"
End Sub
'不按批次分配
Private Sub Command11_Click()
'ADO连接数据库
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim strSQL As String
Dim name As String, pass As String
'复制库存表做临时表
On Error Resume Next
strSQL = "select top 1 from Inventorytempwithoutlot"
rs.Open strSQL, CurrentProject.AccessConnection
If (Err) Then
'临时表不存在，复制库存表到临时表
DoCmd.SetWarnings False
strSQL = "select * into Inventorytempwithoutlot from [Inventory-raw]"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Else
'先删除临时表再复制表到临时表
DoCmd.SetWarnings False
strSQL = "drop table [Inventorytempwithoutlot]"
DoCmd.RunSQL strSQL
strSQL = "select * into Inventorytempwithoutlot from [Inventory-raw]"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
On Error GoTo 0
'清空配货报告明细表
strSQL = "delete * from [SO Allocation-without LOT] "
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
'读取so type配置表
Dim sortrs As ADODB.Recordset
Set sortrs = New ADODB.Recordset
Dim sortorder As String
sortorder = ""
strSQL = "select * from [orderstatus] order by id"
sortrs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If sortrs.EOF Then
'MsgBox "请检查排序配置表!"
Else
'sortorder = sortorder + " [Ship to]"
Dim count As Integer
Dim laststr As String
laststr = "999999)"
count = 1
Do While Not sortrs.EOF
sortorder = sortorder + " IIf ([Order Status] ='" & sortrs("Order Status") & "'," & sortrs("id") & ","
If count = sortrs.RecordCount Then
sortorder = sortorder + laststr
Else
laststr = laststr + ")"
count = count + 1
End If
sortrs.MoveNext
Loop
End If
sortrs.Close
'读取ship to 配置
Dim shiptors As ADODB.Recordset
Set shiptors = New ADODB.Recordset
Dim sortshipto As String
sortshipto = ""
strSQL = "select * from [shipto] order by id"
shiptors.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If shiptors.EOF Then
'MsgBox "请检查排序配置表!"
Else
Dim count2 As Integer
Dim laststr2 As String
laststr2 = "999999)"
count2 = 1
Do While Not shiptors.EOF
sortshipto = sortshipto + " IIf ([Ship To] =" & shiptors("Ship To") & "," & shiptors("id") & ","
If count2 = shiptors.RecordCount Then
sortshipto = sortshipto + laststr2
Else
laststr2 = laststr2 + ")"
count2 = count2 + 1
End If
shiptors.MoveNext
Loop
End If
shiptors.Close
strSQL = "select * from [SO Backlog Report-raw]"
rs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If rs.EOF Then
MsgBox "请检查源数据！"
Else
'读取ship to 配置[Location Number]
Dim Locationrs As ADODB.Recordset
Set Locationrs = New ADODB.Recordset
Dim sortLocation As String
sortLocation = ""
strSQL = "select * from [LocationNumber] order by id"
Locationrs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If Locationrs.EOF Then
'MsgBox "请检查排序配置表!"
Else
Dim count3 As Integer
Dim laststr3 As String
laststr3 = "999999)"
count3 = 1
Do While Not Locationrs.EOF
sortLocation = sortLocation + " IIf ([Location Number] ='" & Locationrs("Location Number") & "'," & Locationrs("id") & ","
If count3 = Locationrs.RecordCount Then
sortLocation = sortLocation + laststr3
Else
laststr3 = laststr3 + ")"
count3 = count3 + 1
End If
Locationrs.MoveNext
Loop
End If
Locationrs.Close
'循环订单插入配货报告表
Do While Not rs.EOF
'MsgBox "'" & rs("ordernumber") & "'"
Dim Inrs As ADODB.Recordset
Set Inrs = New ADODB.Recordset
'Dim strInSQL As String
strSQL = "select * from [Inventorytempwithoutlot] where [Item Number]='" & rs("2nd Item Number") & "' and [Purchasing Qty]>0" + " order by " + sortLocation
Inrs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If Inrs.EOF Then
'向配货报插一条数据（对应的库存信息空着）
strSQL = "INSERT INTO [SO Allocation-without LOT]([BU],[Order Status],[SUB BU],[Or Date Ty],[Order Number],[Or Ty],[Line Number],[2nd Item Number],[Quantity],[UOM],[Unit Price],"
strSQL = strSQL + "[Total Amount],[Extended Amount],[Quantity Shipped],[Quantity Backordered],[Branch/Plant],[Location],[Lot Serial Number],[Last Status],[Next Status],[Pick Number]"
strSQL = strSQL + ",[Document Number],[Doc Ty],[Invoice Date],[Ship To Description],[Ship To],[Sold To],[Customer PO],[Description 1],[Order Date],[Request Date],[Price Effective Date]"
strSQL = strSQL + ",[可配货数量],[可配货金额])"
strSQL = strSQL + " values('" & rs("bu") & "','" & rs("Order Status") & "','" & rs("SUB BU") & "','" & rs("Or Date Ty") & "','" & rs("Order Number") & "','" & rs("Or Ty") & "'"
strSQL = strSQL + ",'" & rs("Line Number") & "','" & rs("2nd Item Number") & "','" & rs("Quantity") & "','" & rs("UOM") & "','" & rs("Unit Price") & "','" & rs("Total Amount") & "'"
strSQL = strSQL + ",'" & rs("Extended Amount") & "','" & rs("Quantity Shipped") & "','" & rs("Quantity Backordered") & "','" & rs("Branch/Plant") & "','" & rs("Location") & "'"
strSQL = strSQL + ",'" & rs("Lot Serial Number") & "','" & rs("Last Status") & "','" & rs("Next Status") & "','" & rs("Pick Number") & "'"
strSQL = strSQL + ",'" & rs("Document Number") & "','" & rs("Doc Ty") & "','" & rs("Invoice Date") & "','" & Replace(rs("Ship To Description"), "'", " ") & "','" & rs("Ship To") & "'"
strSQL = strSQL + ",'" & rs("Sold To") & "','" & rs("Customer PO") & "','" & Replace(rs("Description 1"), "'", " ") & "','" & rs("Order Date") & "','" & rs("Request Date") & "','" & rs("Price Effective Date") & "'"
strSQL = strSQL + ",0,0)"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Else
Dim num As Integer
num = 0
Dim Allocableamount As Double
Allocableamount = 0
Dim account As Integer
account = 1
Do While Not Inrs.EOF
If (num >= rs("Quantity")) Then
Exit Do
Else
If (Inrs("Purchasing Qty") + num >= rs("Quantity")) Then
'更新库存
DoCmd.SetWarnings False
Dim aaa As Double
aaa = (rs("Quantity") - num) * Inrs("SBJ DNP ")
strSQL = "update [Inventorytempwithoutlot] set [Purchasing Qty]=" & Inrs("Purchasing Qty") - rs("Quantity") + num & ",[Purchasing Stock Value(DNP)]=" & Inrs("Purchasing Stock Value(DNP)") - aaa & " where [B/P#]=" & Inrs("B/P#") & " and [Location Number]='" & Inrs("Location Number") & "'"
strSQL = strSQL + " and [Item Number]='" & Inrs("Item Number") & "' and [Purchasing Qty]=" & Inrs("Purchasing Qty") & " and [Purchasing Stock Value(DNP)]=" & Inrs("Purchasing Stock Value(DNP)") & ""
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
num = num + (rs("Quantity") - num)
Allocableamount = Allocableamount + aaa
strSQL = "INSERT INTO [SO Allocation-without LOT]([BU],[Order Status],[SUB BU],[Or Date Ty],[Order Number],[Or Ty],[Line Number],[2nd Item Number],[Quantity],[UOM],[Unit Price],"
strSQL = strSQL + "[Total Amount],[Extended Amount],[Quantity Shipped],[Quantity Backordered],[Branch/Plant],[Location],[Lot Serial Number],[Last Status],[Next Status],[Pick Number]"
strSQL = strSQL + ",[Document Number],[Doc Ty],[Invoice Date],[Ship To Description],[Ship To],[Sold To],[Customer PO],[Description 1],[Order Date],[Request Date],[Price Effective Date]"
strSQL = strSQL + ",[可配货数量],[可配货金额])"
strSQL = strSQL + " values('" & rs("bu") & "','" & rs("Order Status") & "','" & rs("SUB BU") & "','" & rs("Or Date Ty") & "','" & rs("Order Number") & "','" & rs("Or Ty") & "'"
strSQL = strSQL + ",'" & rs("Line Number") & "','" & rs("2nd Item Number") & "','" & rs("Quantity") & "','" & rs("UOM") & "','" & rs("Unit Price") & "','" & rs("Total Amount") & "'"
strSQL = strSQL + ",'" & rs("Extended Amount") & "','" & rs("Quantity Shipped") & "','" & rs("Quantity Backordered") & "','" & rs("Branch/Plant") & "','" & rs("Location") & "'"
strSQL = strSQL + ",'" & rs("Lot Serial Number") & "','" & rs("Last Status") & "','" & rs("Next Status") & "','" & rs("Pick Number") & "'"
strSQL = strSQL + ",'" & rs("Document Number") & "','" & rs("Doc Ty") & "','" & rs("Invoice Date") & "','" & Replace(rs("Ship To Description"), "'", " ") & "','" & rs("Ship To") & "'"
strSQL = strSQL + ",'" & rs("Sold To") & "','" & rs("Customer PO") & "','" & Replace(rs("Description 1"), "'", " ") & "','" & rs("Order Date") & "','" & rs("Request Date") & "','" & rs("Price Effective Date") & "'"
strSQL = strSQL + ",'" & num & "','" & Allocableamount & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Else
'更新库存
strSQL = "update [Inventorytempwithoutlot] set [Purchasing Qty]=0,[Purchasing Stock Value(DNP)]=0 where [B/P#]=" & Inrs("B/P#") & " and [Location Number]='" & Inrs("Location Number") & "'"
strSQL = strSQL + " and [Item Number]='" & Inrs("Item Number") & "' and [Purchasing Qty]=" & Inrs("Purchasing Qty") & " and [Purchasing Stock Value(DNP)]=" & Inrs("Purchasing Stock Value(DNP)") & ""
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
num = num + Inrs("Purchasing Qty")
Allocableamount = Allocableamount + Inrs("Purchasing Stock Value(DNP)")
If account = Inrs.RecordCount Then
strSQL = "INSERT INTO [SO Allocation-without LOT]([BU],[Order Status],[SUB BU],[Or Date Ty],[Order Number],[Or Ty],[Line Number],[2nd Item Number],[Quantity],[UOM],[Unit Price],"
strSQL = strSQL + "[Total Amount],[Extended Amount],[Quantity Shipped],[Quantity Backordered],[Branch/Plant],[Location],[Lot Serial Number],[Last Status],[Next Status],[Pick Number]"
strSQL = strSQL + ",[Document Number],[Doc Ty],[Invoice Date],[Ship To Description],[Ship To],[Sold To],[Customer PO],[Description 1],[Order Date],[Request Date],[Price Effective Date]"
strSQL = strSQL + ",[可配货数量],[可配货金额])"
strSQL = strSQL + " values('" & rs("bu") & "','" & rs("Order Status") & "','" & rs("SUB BU") & "','" & rs("Or Date Ty") & "','" & rs("Order Number") & "','" & rs("Or Ty") & "'"
strSQL = strSQL + ",'" & rs("Line Number") & "','" & rs("2nd Item Number") & "','" & rs("Quantity") & "','" & rs("UOM") & "','" & rs("Unit Price") & "','" & rs("Total Amount") & "'"
strSQL = strSQL + ",'" & rs("Extended Amount") & "','" & rs("Quantity Shipped") & "','" & rs("Quantity Backordered") & "','" & rs("Branch/Plant") & "','" & rs("Location") & "'"
strSQL = strSQL + ",'" & rs("Lot Serial Number") & "','" & rs("Last Status") & "','" & rs("Next Status") & "','" & rs("Pick Number") & "'"
strSQL = strSQL + ",'" & rs("Document Number") & "','" & rs("Doc Ty") & "','" & rs("Invoice Date") & "','" & Replace(rs("Ship To Description"), "'", " ") & "','" & rs("Ship To") & "'"
strSQL = strSQL + ",'" & rs("Sold To") & "','" & rs("Customer PO") & "','" & Replace(rs("Description 1"), "'", " ") & "','" & rs("Order Date") & "','" & rs("Request Date") & "','" & rs("Price Effective Date") & "'"
strSQL = strSQL + ",'" & num & "','" & Allocableamount & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Else
account = account + 1
End If
End If
End If
Inrs.MoveNext
Loop
End If
rs.MoveNext
Loop
End If
Inrs.Close
rs.Close
'打开表按ship to ,order status 排序
DoCmd.OpenTable "SO Allocation-without LOT"
End Sub
'余量库存报告
Private Sub Command12_Click()
'ADO连接数据库
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim strSQL As String
'清空库存余量报告
strSQL = "delete * from [Available Inventory]"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
'查询所有库存
strSQL = "select * from [Inventory-raw]"
rs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If rs.EOF Then
MsgBox "请检查源数据！"
Else
Do While Not rs.EOF
'查询库存临时表
Dim rstemp As ADODB.Recordset
Set rstemp = New ADODB.Recordset
'strSQL = "select * from [Inventorytemp] where [B/P#]=" & rs("B/P#") & " and [Location Number]='" & Inrs("Location Number") & "' and [Item Number]='" & Inrs("Item Number") & "' and [Lot Number]='" & Inrs("Lot Number") & "'"
strSQL = "select * from [Inventorytemp] where [B/P#]=" & rs("B/P#") & " and [Location Number]='" & rs("Location Number") & "' and [Item Number]='" & rs("Item Number") & "' and [Lot Number]='" & rs("Lot Number") & "'"
rstemp.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If rstemp.EOF Then
MsgBox "请检查源数据！"
ElseIf (rstemp.RecordCount = 1) Then
strSQL = "INSERT INTO [Available Inventory]([B/P#],[Location Number],[Item Number],[Item Description],[Purchasing UOM],[Packing Size],[Unit Price in local Currency]"
strSQL = strSQL + ",[Amount Price in local Currency],[Vendor Code],[Vendor Name],[Manufacturing Date],[Expiry Date],[Implant Instruments(Y/N)],[Product Line Name],[Report Date],[Local Product Group]"
strSQL = strSQL + ",[License Number],[License Effective Date],[License Expiry Date],[XRef SuppItem number],[BU],[Purchasing Qty],[SBJ DNP ],[Purchasing Stock Value(DNP)],[Bridge Buy (Y or N)],[PLCM Investment]"
strSQL = strSQL + ",[Committed Qty],[Commtitted INV Amout by DNP],[Available INV Qty],[Available INV Amount by DNP])"
strSQL = strSQL + " values('" & rs("B/P#") & "','" & rs("Location Number") & "','" & rs("Item Number") & "','" & Replace(rs("Item Description"), "'", " ") & "','" & rs("Purchasing UOM") & "','" & rs("Packing Size") & "'"
strSQL = strSQL + ",'" & rs("Unit Price in local Currency") & "','" & rs("Amount Price in local Currency") & "','" & rs("Vendor Code") & "','" & rs("Vendor Name") & "','" & rs("Manufacturing Date") & "'"
strSQL = strSQL + ",'" & rs("Expiry Date") & "','" & rs("Implant Instruments(Y/N)") & "','" & rs("Product Line Name") & "','" & rs("Report Date") & "','" & rs("Local Product Group") & "'"
strSQL = strSQL + ",'" & Replace(rs("License Number"), "'", "") & "','" & rs("License Effective Date") & "','" & rs("License Expiry Date") & "','" & Replace(rs("XRef SuppItem number"), "'", " ") & "'"
strSQL = strSQL + ",'" & rs("BU") & "','" & rs("Purchasing Qty") & "','" & rs("SBJ DNP ") & "','" & rs("Purchasing Stock Value(DNP)") & "','" & rs("Bridge Buy (Y or N)") & "','" & rs("PLCM Investment") & "'"
strSQL = strSQL + ",'" & rs("Purchasing Qty") & "','" & rs("Purchasing Qty") * rs("SBJ DNP ") & "','" & rstemp("Purchasing Qty") & "','" & rstemp("Purchasing Stock Value(DNP)") & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Else
MsgBox "请检查源数据!"
End If
rs.MoveNext
Loop
End If
'打开表
DoCmd.OpenTable "Available Inventory"
End Sub
Private Sub Command13_Click()
'ADO连接数据库
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim strSQL As String
'清空库存余量报告
strSQL = "delete * from [report]"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
'按bu,客户描述查订单和Allocation
Dim onwhere As String
strSQL = "SELECT a.[bu] AS BU, a.[Dealer] AS Dealer, a.[Overdue] AS [OverdueOrderStatus], a.[Current] AS [CurrentOrderStatus],"
strSQL = strSQL + "a.[Future] AS [FutureOrderStatus], b.[Overdue] AS [OverdueAllocation], b.[Current] AS [CurrentAllocation], "
strSQL = strSQL + "b.[Future] AS [FutureAllocation]"
strSQL = strSQL + " FROM (SELECT Min([SO Backlog Report-raw].bu) AS BU, Max([SO Backlog Report-raw].[Ship To Description]) AS Dealer, Sum(iif([Order Status]='Overdue'"
strSQL = strSQL + ",[Quantity],0)) AS Overdue, Sum(iif([Order Status]='Current',[Quantity],0)) AS [Current], Sum(iif([Order Status]='Future',"
strSQL = strSQL + "[Quantity],0)) AS Future FROM [SO Backlog Report-raw] GROUP BY [SO Backlog Report-raw].[bu], [SO Backlog Report-raw].[Ship To Description]) AS a "
'strSQL = strSQL + " Inner JOIN (SELECT Min([SO Allocation-BY LOT].bu) AS BU, Max([SO Allocation-BY LOT].[Ship To Description]) AS Dealer, Sum(iif([Order Status]='Overdue',[可配货数量],0)) AS Overdue, "
strSQL = strSQL + " Left JOIN (SELECT Min([SO Allocation-BY LOT].bu) AS BU, Max([SO Allocation-BY LOT].[Ship To Description]) AS Dealer, Sum(iif([Order Status]='Overdue',[可配货数量],0)) AS Overdue, "
strSQL = strSQL + "Sum(iif([Order Status]='Current',[可配货数量],0)) AS [Current], Sum(iif([Order Status]='Future',[可配货数量],0)) AS Future FROM [SO Allocation-BY LOT]"
'strSQL = strSQL + "GROUP BY [SO Allocation-BY LOT].[bu], [SO Allocation-BY LOT].[Ship To Description]) AS b On (a.[Dealer]=b.[Dealer]) and (a.[bu]=b.[bu])"
strSQL = strSQL + "GROUP BY [SO Allocation-BY LOT].[bu], [SO Allocation-BY LOT].[Ship To Description]) AS b On (Replace(a.[Dealer],""'"","" "")=b.[Dealer]) and (a.[bu]=b.[bu])"
rs.Open strSQL, CurrentProject.AccessConnection, adOpenKeyset
If rs.EOF Then
MsgBox "请检查源数据！"
Else
Dim Overduerate As String
Dim Currentrate As String
Dim Futurerate As String
Dim Total As String
Dim Overdueaccount As Long
Overdueaccount = 0
Dim Currenteaccount As Long
Currenteaccount = 0
Dim Futureaccount As Long
Futureaccount = 0
Dim AllocationOverdueaccount As Long
AllocationOverdueaccount = 0
Dim AllocationCurrenteaccount As Long
AllocationCurrenteaccount = 0
Dim AllocationFutureaccount As Long
AllocationFutureaccount = 0
Do While Not rs.EOF
Overdueaccount = Overdueaccount + rs("OverdueOrderStatus")
Currenteaccount = Currenteaccount + rs("CurrentOrderStatus")
Futureaccount = Futureaccount + rs("FutureOrderStatus")
If (IsNull(rs("OverdueAllocation"))) Then
Else
AllocationOverdueaccount = AllocationOverdueaccount + rs("OverdueAllocation")
End If
If (IsNull(rs("CurrentAllocation"))) Then
Else
AllocationCurrenteaccount = AllocationCurrenteaccount + rs("CurrentAllocation")
End If
If (IsNull(rs("FutureAllocation"))) Then
Else
AllocationFutureaccount = AllocationFutureaccount + rs("FutureAllocation")
End If
If (rs("OverdueOrderStatus") = 0 Or IsNull(rs("OverdueAllocation"))) Then
Overduerate = "0%"
Else
Overduerate = CStr(Round(rs("OverdueAllocation") / rs("OverdueOrderStatus"), 3) * 100) + "%"
End If
If (rs("CurrentOrderStatus") = 0 Or IsNull(rs("CurrentAllocation"))) Then
Currentrate = "0%"
Else
Currentrate = CStr(Round(rs("CurrentAllocation") / rs("CurrentOrderStatus"), 3) * 100) + "%"
End If
If (rs("FutureOrderStatus") = 0 Or IsNull(rs("FutureAllocation"))) Then
Futurerate = "0%"
Else
Futurerate = CStr(Round(rs("FutureAllocation") / rs("FutureOrderStatus"), 3) * 100) + "%"
End If
If (rs("OverdueOrderStatus") + rs("FutureOrderStatus") + rs("CurrentOrderStatus")) = 0 Then
Total = "0%"
Else
Total = CStr(Round((rs("OverdueAllocation") + rs("FutureAllocation") + rs("CurrentAllocation")) / (rs("OverdueOrderStatus") + rs("FutureOrderStatus") + rs("CurrentOrderStatus")), 3) * 100) + "%"
End If
strSQL = "insert into report([bu],[Dealer],[超需求日未提货(Order Status)],[需求日在当月(Order Status)],[需求日大于当月(Order Status)],[超需求日未提货(Allocation)],[需求日在当月(Allocation)],[需求日大于当月(Allocation]"
strSQL = strSQL + ",[超期配货率],[当月配货率],[未来需求配货率],[总配货率])"
',[Comments]
strSQL = strSQL + "values('" & rs("BU") & "','" & Replace(rs("Dealer"), "'", " ") & "','" & rs("OverdueOrderStatus") & "','" & rs("CurrentOrderStatus") & "','" & rs("FutureOrderStatus") & "',"
strSQL = strSQL + "'" & rs("OverdueAllocation") & "','" & rs("CurrentAllocation") & "','" & rs("FutureAllocation") & "','" & Overduerate & "','" & Currentrate & "','" & Futurerate & "','" & Total & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
rs.MoveNext
Loop
'追加合计行
Dim totalOverduerate As String
Dim totalCurrentrate As String
Dim totalFuturerate As String
Dim totalTotal As String
If Overdueaccount = 0 Then
totalOverduerate = "0%"
Else
totalOverduerate = CStr(Round(AllocationOverdueaccount / Overdueaccount, 3) * 100) + "%"
End If
If Currenteaccount = 0 Then
totalCurrentrate = "0%"
Else
totalCurrentrate = CStr(Round(AllocationCurrenteaccount / Currenteaccount, 3) * 100) + "%"
End If
If Futureaccount = 0 Then
totalFuturerate = "0%"
Else
totalFuturerate = CStr(Round(AllocationFutureaccount / Futureaccount, 3) * 100) + "%"
End If
If (Overdueaccount + Currenteaccount + Futureaccount) = 0 Then
totalTotal = "0%"
Else
totalTotal = CStr(Round((AllocationOverdueaccount + AllocationCurrenteaccount + AllocationFutureaccount) / (Overdueaccount + Currenteaccount + Futureaccount), 3) * 100) + "%"
End If
strSQL = "insert into report([bu],[Dealer],[超需求日未提货(Order Status)],[需求日在当月(Order Status)],[需求日大于当月(Order Status)],[超需求日未提货(Allocation)],[需求日在当月(Allocation)],[需求日大于当月(Allocation]"
strSQL = strSQL + ",[超期配货率],[当月配货率],[未来需求配货率],[总配货率])"
',[Comments]
strSQL = strSQL + "values('合计',' ','" & Overdueaccount & "','" & Currenteaccount & "','" & Futureaccount & "',"
strSQL = strSQL + "'" & AllocationOverdueaccount & "','" & AllocationCurrenteaccount & "','" & AllocationFutureaccount & "','" & totalOverduerate & "','" & totalCurrentrate & "','" & totalFuturerate & "','" & totalTotal & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
rs.Close
DoCmd.OpenTable "report"
End Sub
ADO需添加引用