Round elements of a sum to match a total

When there is no exact match

The cake split

The cheese cake is precut in 12 slices, and you have played with your friends to win the largest share.

The method is, of course, to sum all points achieved and then calculate the share for each player. However, that results in decimal values, meaning that the slices should be sub-sliced and we don't want that. Thus, the shares are rounded to full slices.

The second column shows the points achieved. This is the left graph above.

Then follows the players' shares of the cake and how many slices that equals.

The slices are rounded to obtain the requested count of full slices, but these add up to 13. Thus, one slice has to go, but which? There are some options:

• Reduce the largest count of slices by one
• Delete the slice that has the smallest share
• Delete a random slice

The answer is to reduce where the impact will be smallest. We have two players with three slices, but player 5's count has already been rounded down. Reducing player 1's count of slices will still leave him or here two slices.

Two players have been rounded up to one slice. Reducing either of these to zero will have a very large impact, 100%, on the share.

Thus player 1 is the candidate to give up a slice.

The last column lists the final count of slices, adding up to the twelve available. This is the right graph above.

In this small example, the result is easy to figure out. But for a larger count of players - or other items like invoice lines or measurements - it will be difficult to figure out the optimum result. You will need a function to carry it out.

Mix of small and large values

Let's take another example where the outcome may not be that obvious. Here, four small values are added with one much larger. The sum of the rounded values (1443) differs with 2 from the rounded total (1441).

But which values should be corrected?

You may argue, that the largest value(s) should be corrected, as the imposed error will be the smallest relative to the value. But it would be regarded as strange, that (here) the only value that is hardly rounded would be the one to adjust while the other values, that are rounded up or down quite a lot, should remain.

However, you could just as well argue, that those values with the largest difference in the rounded value should be adjusted. In the table, that is seen in column Difference. That would call for an adjustment of the values 3 and 2, but leaves the question, it not the value of 4 more likely should have been adjusted.

There is no single right or wrong method to follow, but a good compromise that will work well in most cases is to weigh the difference meaning multiplying the value and the difference. 

Those values are listed in the next column. Here you'll see, that the large value due to its very small difference results in with a low figure and that the smallest values, 0.6 rounded to 1, also results in a low figure due to the very low input value. The two at the top (highlighted) will then be those to adjust:

The final values are listed in column Result, and the total is seen to match the rounded total of the input values.

If no solution exists

In some situations, there may be several identical input values, and the rounded total doesn't match the sum of the rounded values. So which value to adjust, if adjusting all would generate another mismatch?

You could decide for picking an arbitrary item to adjust. But that is no good solution because several calls of the function with identical input values then might generate different result sets. Thus, a simple rule has been set up:

If one of several identical values must be adjusted, pick the first.

An example is shown here:

Note, that item 2 has been adjusted down by 0.01 for the sum to match the rounded 123.3334.

Make the items match

A function to do this for us could take as input an array of the items or values to round and return an array with the rounded values.

This basic method would:

1. Read the values from the array and sum these
2. Round the sum to obtain the total
3. Scale and round the values
4. Sum the rounded values
5. Adjust the rounded values until the sum of these matches the total
6. Return an array with the rounded and corrected values

In addition to basic rounding, the function provided here will:

• Accept positive, negative, zero, and mixed values
• Reverse the values if the sign of the sum doesn't match the sign of the requested total
• Scale the values to make the sum of these match the requested total ("cake splitting")
• Handle very small and very large values

That's quite a few steps and conditions to take care of, thus the function can appear a little long-winded, even though the code is extensively commented in-line. So let's briefly walk through the steps. 

Read the values from the array and sum these

The first thing to check is if an array is passed. If so, this is looped and the values are summed as Decimal, If values are very large, the function falls back to use Double.

    ' 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

Now we have the rounded values and the sum.

Round the sum to obtain the total

Next step it to round the requested total so we know what to aim for. Note, that if either the sum of the values or the total is zero, no scaling is possible as it would imply a division by zero. Also, the sign is recorded for later use.

You will notice, that function RoundMid is used here. This is a precision rounding function you can study here:

Rounding values up, down, by 4/5, or to significant figures

    ' 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

Now we have the basic bits and pieces and can start creating the output.

Scale and round the values and sum the rounded values

For the output, we create two arrays - one to hold the values and one to hold the sorting of these.

The first we fill here, later we fill the array for sorting.

    ' 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

Note, that positive and negative values are summed separately to be able to take care of special cases as seen next.

Adjust the rounded values until the sum of these matches the total

This is the crucial part where we use the array to hold the sort order of the values.

First a third array, SortingValues, is created and filled with the calculated values to sort on. Note, that the values are made absolute.

These two arrays are then sorted by an external function, QuickSortIndex, which is a traditional quick sort function modified to leave the source array untouched and leave the sorting order in the array for the sort order.

The sorting is used to order the values after the relative error the rounding of these will cause. This may seem cryptic, but those values are used later to determine the order in which values should be corrected up or down to make the sum of the rounded values match the requested total.

In case of a mismatch, the difference is calculated and distributed among the values following the sort order found. 

Note, that if a value is corrected and an identical value reversely signed exists, this is corrected as well. This way, if two values were intended to outweigh each other, they will still do so after a correction.

Just about every step is documented by the in-line comments.

    ' 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

That nearly completes the task.

Return an array with the rounded and corrected values

This final step is where the recorded value of Sign is checked and applied. If needed, the resulting array is simply looped, and the values are reversed.

    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

Finally, the processed array with the resulting values is returned.
Also, the rounded total - declared ByRef  - is returned by reference.

Calling the function

The function takes three arguments and returns an array:

Public Function RoundSum( _
    ByVal Values As Variant, _
    Optional ByRef Total As Variant, _
    Optional ByVal NumDigitsAfterDecimal As Long) _
    As Variant

Of these, Values is the input array, Total is the total value to return, and NumDigitsAfterDecimal determines how the values are rounded. If positive, rounding will be with decimals, if zero rounding will be to integer values, and - if negative - rounding will be to 10, 100, 1000, etc.

If Total is not specified or is zero, the values will be rounded to have a sum that equals the rounded sum of the unrounded values.

The usage is quite simple:

' Create an array for the example input values.
Values = Array(1.66, 1.66, 1.67, -1.7, 1.66)

' Specify the requested total (optional).
RequestedTotal = -11.12

' Specify the rounding, here with one decimal.
NumDigitsAfterDecimal = 1
' This will entail an expected (rounded) total of -11.1.

' Call the function with the parameters and return an array.
Result = RoundSum(Values, Total, NumDigitsAfterDecimal)

' Now, array Result will hold the rounded values, and Total the rounded total.
' If listed, the rounded values and total will be:
'
' Item         Result
'  0            -3.7  
'  1            -3.7  
'  2            -3.8  
'  3             3.8  
'  4            -3.7  
' Total        -11.1

Note that the signs are reversed, as we specified a negative total while the sum of the values was positive.

Rounding a recordset

Also the values of a field of a recordset can be rounded to match their total. A sub in the demo module shows how:

' Round the values of one field of a recordset and write the rounded values (matching the total)
' to another field of the recordset.
'
' Example:
'   Rounding the values to two decimals for the sum to match the original sum:
'
'   RoundRecordSum CurrentDb.OpenRecordset("Select Value, RoundedValue From SomeTable"), 0, 2
'
' 2024-03-11. Gustav Brock, Cactus Data ApS, CPH.
'
Public Sub RoundRecordSum( _
    ByRef Records As DAO.Recordset, _
    ByVal Total As Double, _
    Optional ByVal NumDigitsAfterDecimal As Long)

    Dim Rows        As Variant
    Dim Values()    As Double
    Dim Value       As Double
    Dim Sum         As Double
    Dim RecordCount As Long
    Dim Index       As Long
    
    If Records.RecordCount = 0 Then
        Exit Sub
    End If
    
    ' Count records.
    Records.MoveLast
    Records.MoveFirst
    RecordCount = Records.RecordCount
    ' Retrieve multi-dimensional array.
    Rows = Records.GetRows(RecordCount)
    
    ' Read values from the first field of the recordset.
    ' Convert to one-dimensional array and calculate the sum.
    ReDim Values(0 To UBound(Rows, 2))
    For Index = LBound(Values) To UBound(Values)
        Value = Rows(0, Index)
        Values(Index) = Value
        Sum = Sum + Value
        Debug.Print Value
    Next
    Debug.Print "Sum:", Sum
    
    ' Adjust sum of output if needed.
    If Total = 0 Then
        Total = Sum
    End If
    
    ' Round the array of values.
    Values = RoundSum(Values, Total, NumDigitsAfterDecimal)
    
    ' Write the values to the second field of the recordset.
    Total = 0
    Records.MoveFirst
    For Index = LBound(Values) To UBound(Values)
        Value = Values(Index)
        If Records(1).Value <> Value Then
            Records.Edit
            Records(1).Value = Value
            Records.Update
        End If
        Total = Total + Value
        Records.MoveNext
    Next
    Debug.Print "Total:", Total
    
End Sub

Further reading

As mentioned above, another article about demanding rounding is online. This covers basic rounding:

Rounding values up, down, by 4/5, or to significant figures

An extended discussion can be found on Wikipedia:

Rounding of summands preserving the total

Download

The current version can always be found at GitHub VBA.Round

The version for this article is here:  Rounding 1.4.4.zip. This includes a Microsoft Access 365 project.

I hope you found this article useful. You are encouraged to ask questions, report any bugs or make any other comments about it below.

Note: If you need further "Support" about this topic, please consider using the Ask a Question feature of Experts Exchange. I monitor questions asked and would be pleased to provide any additional support required in questions asked in this manner, along with other EE experts.

Please do not forget to press the "Thumbs Up" button if you think this article was helpful and valuable for EE members.