Question

Please Open this image, It will Clarify my Question 我有一个包含表的数据库：orders，order_details，Products等。每个订单都有其他字段的总计，运费_成本等。每个order_details都有一个小计，当然还有其他字段。我想从该订单的Freight_cost总数中计算出该订单中每个商品的运费价值份额。请在我的问题开始处打开图片，以明确说明我要做什么。

Answer 1

如果我正确理解了您的问题，也许会有所帮助。最简单的方法是创建一个查询，该查询扩展了order_details表以包括计算出的变量itemfreightcost

这为您提供了一个虚拟表，您可以在该表上创建表单或报表：

注释1：我认为很自然，所以在订购明细表和项目运费计算中包括了数量。

注释2：itemfreightcost的表达式为itemfreightcost：[order_details]！[小计] * [order_details]！[ItemQuantity] / [Orders]！[Freight_Cost]。换句话说，商品价格*数量除以总运费。

注释3：您还可以基于订单和订单明细创建报表，并将itemfreightcost计算出的变量直接添加到报表的明细部分。

Answer 2

您可以使用此函数，向其传递数量和总成本的数组，并返回包含明细成本的数组：

' Rounds a series of numbers so the sum of these matches the
' rounded sum of the unrounded values.
' Further, if a requested total is passed, the rounded values
' will be scaled, so the sum of these matches the rounded total.
' In cases where the sum of the rounded values doesn't match
' the rounded total, the rounded values will be adjusted where
' the applied error will be the relatively smallest.
'
' The series of values to round must be passed as an array.
' The data type can be any numeric data type, and values can have
' any value.
' Internally, the function uses Decimal to achieve the highest
' precision and Double when the values exceed the range of Decimal.
'
' The result is an array holding the rounded values, as well as
' (by reference) the rounded total.
'
' If non-numeric values are passed, an error is raised.
'
' Requires:
'   RoundMid
'
' 2018-03-26. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function RoundSum( _
    ByVal Values As Variant, _
    Optional ByRef Total As Variant, _
    Optional ByVal NumDigitsAfterDecimal As Long) _
    As Variant

    Dim SortedItems()   As Long
    Dim RoundedValues   As Variant
    Dim SortingValues   As Variant

    Dim Sum             As Variant
    Dim Value           As Variant
    Dim RoundedSum      As Variant
    Dim RoundedTotal    As Variant
    Dim PlusSum         As Variant
    Dim MinusSum        As Variant
    Dim RoundedPlusSum  As Variant
    Dim RoundedMinusSum As Variant

    Dim ErrorNumber     As Long
    Dim Item            As Long
    Dim Sign            As Variant
    Dim Ratio           As Variant
    Dim Difference      As Variant
    Dim Delta           As Variant
    Dim SortValue       As Variant

    ' Raise error if an array is not passed.
    Item = UBound(Values)

    ' Ignore errors while summing the values.
    On Error Resume Next
    If Err.Number = 0 Then
        ' Try to sum the passed values as a Decimal.
        Sum = CDec(0)
        For Item = LBound(Values) To UBound(Values)
            If IsNumeric(Values(Item)) Then
                Sum = Sum + CDec(Values(Item))
                If Err.Number <> 0 Then
                    ' Values exceed range of Decimal.
                    ' Exit loop and try using Double.
                    Exit For
                End If
            End If
        Next
    End If
    If Err.Number <> 0 Then
        ' Try to sum the passed values as a Double.
        Err.Clear
        Sum = CDbl(0)
        For Item = LBound(Values) To UBound(Values)
            If IsNumeric(Values(Item)) Then
                Sum = Sum + CDbl(Values(Item))
                If Err.Number <> 0 Then
                    ' Values exceed range of Double.
                    ' Exit loop and raise error.
                    Exit For
                End If
            End If
        Next
    End If
    ' Collect the error number as "On Error Goto 0" will clear it.
    ErrorNumber = Err.Number
    On Error GoTo 0
    If ErrorNumber <> 0 Then
        ' Extreme values. Give up.
        Error.Raise ErrorNumber
    End If

    ' Correct a missing or invalid parameter value for Total.
    If Not IsNumeric(Total) Then
        Total = 0
    End If
    If Total = 0 Then
        RoundedTotal = 0
    Else
        ' Round Total to an appropriate data type.
        ' Set data type of RoundedTotal to match Sum.
        Select Case VarType(Sum)
            Case vbSingle, vbDouble
                Value = CDbl(Total)
            Case Else
                Value = CDec(Total)
        End Select
        RoundedTotal = RoundMid(Value, NumDigitsAfterDecimal)
    End If

    ' Calculate scaling factor and sign.
    If Sum = 0 Or RoundedTotal = 0 Then
        ' Cannot scale a value of zero.
        Sign = 1
        Ratio = 1
    Else
        Sign = Sgn(Sum) * Sgn(RoundedTotal)
        ' Ignore error and convert to Double if total exceeds the range of Decimal.
        On Error Resume Next
        Ratio = Abs(RoundedTotal / Sum)
        If Err.Number <> 0 Then
            RoundedTotal = CDbl(RoundedTotal)
            Ratio = Abs(RoundedTotal / Sum)
        End If
        On Error GoTo 0
    End If

    ' Create array to hold the rounded values.
    RoundedValues = Values
    ' Scale and round the values and sum the rounded values.
    ' Variables will get the data type of RoundedValues.
    ' Ignore error and convert to Double if total exceeds the range of Decimal.
    On Error Resume Next
    For Item = LBound(Values) To UBound(Values)
        RoundedValues(Item) = RoundMid(Values(Item) * Ratio, NumDigitsAfterDecimal)
        If RoundedValues(Item) > 0 Then
            PlusSum = PlusSum + Values(Item)
            RoundedPlusSum = RoundedPlusSum + RoundedValues(Item)
            If Err.Number <> 0 Then
                RoundedPlusSum = CDbl(RoundedPlusSum) + CDbl(RoundedValues(Item))
            End If
        Else
            MinusSum = MinusSum + Values(Item)
            RoundedMinusSum = RoundedMinusSum + RoundedValues(Item)
            If Err.Number <> 0 Then
                RoundedMinusSum = CDbl(RoundedMinusSum) + CDbl(RoundedValues(Item))
            End If
        End If
    Next
    RoundedSum = RoundedPlusSum + RoundedMinusSum
    If Err.Number <> 0 Then
        RoundedPlusSum = CDbl(RoundedPlusSum)
        RoundedMinusSum = CDbl(RoundedMinusSum)
        RoundedSum = RoundedPlusSum + RoundedMinusSum
    End If
    On Error GoTo 0

    If RoundedTotal = 0 Then
        ' No total is requested.
        ' Use as total the rounded sum of the passed unrounded values.
        RoundedTotal = RoundMid(Sum, NumDigitsAfterDecimal)
    End If

    ' Check if a correction of the rounded values is needed.
    If (RoundedPlusSum + RoundedMinusSum = 0) And (RoundedTotal = 0) Then
        ' All items are rounded to zero. Nothing to do.
        ' Return zero.
    ElseIf RoundedSum = RoundedTotal Then
        ' Match. Nothing more to do.
    ElseIf RoundedSum = Sign * RoundedTotal Then
        ' Match, except that values shall be reversely signed.
        ' Will be done later before exit.
    Else
        ' Correction is needed.
        ' Redim array to hold the sorting of the rounded values.
        ReDim SortedItems(LBound(Values) To UBound(Values))
        ' Fill array with default sorting.
        For Item = LBound(SortedItems) To UBound(SortedItems)
            SortedItems(Item) = Item
        Next

        ' Create array to hold the values to sort.
        SortingValues = RoundedValues
        ' Fill the array after the relative rounding error and - for items with equal rounding error - the
        ' size of the value of items.
        For Item = LBound(SortedItems) To UBound(SortedItems)
            If Values(SortedItems(Item)) = 0 Then
                ' Zero value.
                SortValue = 0
            ElseIf RoundedPlusSum + RoundedMinusSum = 0 Then
                ' Values have been rounded to zero.
                ' Use original values.
                SortValue = Values(SortedItems(Item))
            ElseIf VarType(Values(SortedItems(Item))) = vbDouble Then
                ' Calculate relative rounding error.
                ' Value is exceeding Decimal. Use Double.
                SortValue = (Values(SortedItems(Item)) * Ratio - CDbl(RoundedValues(SortedItems(Item)))) * (Values(SortedItems(Item)) / Sum)
            Else
                ' Calculate relative rounding error using Decimal.
                SortValue = (Values(SortedItems(Item)) * Ratio - RoundedValues(SortedItems(Item))) * (Values(SortedItems(Item)) / Sum)
            End If
            ' Sort on the absolute value.
            SortingValues(Item) = Abs(SortValue)
        Next

        ' Sort the array after the relative rounding error and - for items with equal rounding error - the
        ' size of the value of items.
        QuickSortIndex SortedItems, SortingValues

        ' Distribute a difference between the rounded sum and the requested total.
        If RoundedPlusSum + RoundedMinusSum = 0 Then
            ' All rounded values are zero.
            ' Set Difference to the rounded total.
            Difference = RoundedTotal
        Else
            Difference = Sgn(RoundedSum) * (Abs(RoundedTotal) - Abs(RoundedSum))
        End If
        ' If Difference is positive, some values must be rounded up.
        ' If Difference is negative, some values must be rounded down.
        ' Calculate Delta, the value to increment/decrement by.
        Delta = Sgn(Difference) * 10 ^ -NumDigitsAfterDecimal

        ' Loop the rounded values and increment/decrement by Delta until Difference is zero.
        For Item = UBound(SortedItems) To LBound(SortedItems) Step -1
            ' If values should be incremented, ignore values rounded up.
            ' If values should be decremented, ignore values rounded down.
            If Sgn(Difference) = Sgn(Values(SortedItems(Item)) * Ratio - RoundedValues(SortedItems(Item))) Then
                ' Adjust this item.
                RoundedValues(SortedItems(Item)) = RoundedValues(SortedItems(Item)) + Delta
                If Item > LBound(SortedItems) Then
                    ' Check if the next item holds the exact reverse value.
                    If Values(SortedItems(Item)) = -Values(SortedItems(Item - 1)) Then
                        ' Adjust the next item as well to avoid uneven incrementing.
                        Item = Item - 1
                        RoundedValues(SortedItems(Item)) = RoundedValues(SortedItems(Item)) - Delta
                        Difference = Difference + Delta
                    End If
                End If
                Difference = Difference - Delta
            End If
            If Difference = 0 Then
                Exit For
            End If
        Next
    End If

    If Sign = -1 Then
        ' The values shall be reversely signed.
        For Item = LBound(RoundedValues) To UBound(RoundedValues)
            RoundedValues(Item) = -RoundedValues(Item)
        Next
    End If

    ' Return the rounded total.
    Total = RoundedTotal
    ' Return the array holding the rounded values.
    RoundSum = RoundedValues

End Function

完整代码位于 GitHub ：VBA.Round

有关代码的详细演练，请研究我的文章：

Round elements of a sum to match a total

不需要登录。只需找到“阅读全文”或类似内容的链接即可。

根据项目在总订单总额中所占的份额，将订单的货运成本值分配给该订单的项目

2 个答案: