Access vba实例

半枫。。。
于 2021-05-30 22:59:15 发布
阅读量1.6k
点赞数 1
分类专栏：数据库
本文链接：https://blog.csdn.net/qq_31584315/article/details/117407458
版权
数据库专栏收录该内容
3 篇文章 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需添加引用
半枫。。。
关注
1
点赞
踩
6

收藏

觉得还不错? 一键收藏
0
评论
Access vba实例

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 = .
复制链接

扫一扫