Access vba实例

数据库 专栏收录该内容
2 篇文章 0 订阅
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需添加引用

  • 0
    点赞
  • 0
    评论
  • 0
    收藏
  • 打赏
    打赏
  • 扫一扫,分享海报

©️2022 CSDN 皮肤主题:大白 设计师:CSDN官方博客 返回首页

打赏作者

来和养生的技术负责人决斗

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值