Rounding numbers to total a specific number?

[JordanSG]

Hello all,

Apologies if this is not possible but I have the following situation:

C	D	E	F	G	H	I (Total)
43.44559	156.9966	246.8499	210.3162	133.299	71.09278	862

<tbody>
</tbody>

<tbody>
</tbody>

I would like to round up each of these cells to the closest number but also so that they match the total in column I?

If you do this with the standard =ROUND function you will get 43, 157, 247, 210, 133, 71 and a total of 861.

So this is forcing me to go back and manually change the 43.44559 to be rounded up to 44 (as it's the closest to being rounded up out of the lot).

Is there any way to make this process automatic in a formula?

Thank you in advance.

 

[ttdk1]

=sumproduct(round(c2:h2,0))

 

[StephenCrump]

Welcome to MrExcel!

This would be tricky with formulas, particularly to accommodate duplicate values, e.g. if you had four values all ending in 0.5, you might need to round two up, and two down.

Here's a UDF approach, which you should array-enter over a range equal in size to the range you want to round.
Someone else may be able to suggest a more succinct way of doing this.

Function RoundToIntegerSum(rng As Range) As Variant

    Dim v As Variant
    Dim lTargetSum As Long, lActualSum As Long
    Dim d As Double, dDiff() As Double, dDiff1() As Double, dDiff2() As Double
    Dim lRows As Long, lCols As Long, r As Long, c As Long, i As Long
    Dim lDiff As Long, lAdj As Long
    Dim bRoundedAlready() As Boolean
    
    v = rng.Value
    lRows = UBound(v)
    lCols = UBound(v, 2)
    ReDim dDiff1(1 To lRows, 1 To lCols)
    ReDim dDiff2(1 To lRows, 1 To lCols)
    ReDim bRoundedAlready(1 To lRows, 1 To lCols)
    lTargetSum = Round(WorksheetFunction.Sum(rng), 0)
    
    For r = 1 To lRows
        For c = 1 To lCols
            d = Int(v(r, c)) + 0.5 - v(r, c)
            If d = 0 Then
                'Default value already 0
            ElseIf d > 0 Then
                dDiff1(r, c) = d
                dDiff2(r, c) = 1
            Else
                dDiff1(r, c) = 1
                dDiff2(r, c) = -d
            End If
            v(r, c) = Round(v(r, c), 0)
            lActualSum = lActualSum + v(r, c)
        Next c
    Next r
        
    lDiff = lTargetSum - lActualSum
    If lDiff > 0 Then
        dDiff = dDiff1
        lAdj = 1
    Else
        dDiff = dDiff2
        lAdj = -1
        lDiff = -lDiff
    End If
        
    For i = 1 To lDiff
        For r = 1 To lRows
            For c = 1 To lCols
                If dDiff(r, c) = WorksheetFunction.Small(dDiff, i) Then
                    If Not bRoundedAlready(r, c) Then
                        v(r, c) = v(r, c) + lAdj
                        bRoundedAlready(r, c) = True
                        GoTo Success
                    End If
                End If
            Next c
        Next r
Success:
    Next i
    
    RoundToIntegerSum = v

End Function

 

[István Hirsch]

Applying the UDF to the OP’s data in C1:H1, I get a sum of 863 because in F1 210.3162 is rounded to 211 (beside 43,4456 is "rounded" to 44, which is correct)

 

[StephenCrump]

Applying the UDF to the OP’s data in C1:H1, I get a sum of 863 because in F1 210.3162 is rounded to 211 (beside 43,4456 is "rounded" to 44, which is correct)

That's curious, I get the correct 862. See workbook attached: https://app.box.com/s/0g32ci10zexjd8p5wro1

Excel 2010

	B	C	D	E	F	G	H	I	J
1	Raw	43.44559	156.9966	246.8499	210.3162	133.299	71.09278	862.0001
2
3	Round to							SUM	CHECK
4	0	44	157	247	210	133	71	862.0000	862.0000
5
6	Round to
7	-1	40.0000	160.0000	250.0000	210.0000	130.0000	70.0000	860.0000	860.0000
8
9	Round to
10	4	43.4456	156.9966	246.8499	210.3162	133.2990	71.0928	862.0001	862.0001

<tbody>
</tbody>

1
​

Just for the heck of it, I've extended the macro to accommodate rounding to n places, rather than just integer (i.e. n = 0):

Function RoundToSum(rng As Range, nPlaces As Long) As Variant

    Dim v As Variant
    Dim dTargetSum As Double, dActualSum As Double
    Dim d As Double, dDiff() As Double, dDifference As Double
    Dim dDiff1() As Double, dDiff2() As Double, dMid As Double, dAdj As Double
    Dim lRows As Long, lCols As Long, r As Long, c As Long, i As Long
    Dim bRoundedAlready() As Boolean
    
    v = rng.Value
    lRows = UBound(v)
    lCols = UBound(v, 2)
    ReDim dDiff1(1 To lRows, 1 To lCols)
    ReDim dDiff2(1 To lRows, 1 To lCols)
    ReDim bRoundedAlready(1 To lRows, 1 To lCols)
    dTargetSum = WorksheetFunction.Round(WorksheetFunction.Sum(rng), nPlaces)
    dAdj = 10 ^ -nPlaces
    dMid = dAdj / 2
    
    For r = 1 To lRows
        For c = 1 To lCols
            d = WorksheetFunction.Floor(v(r, c), dAdj) + dMid - v(r, c)
            If d = 0 Then
                'Default value already 0
            ElseIf d > 0 Then
                dDiff1(r, c) = d
                dDiff2(r, c) = dAdj
            Else
                dDiff1(r, c) = dAdj
                dDiff2(r, c) = -d
            End If
            v(r, c) = WorksheetFunction.Round(v(r, c), nPlaces)
            dActualSum = dActualSum + v(r, c)
        Next c
    Next r
        
    dDifference = dTargetSum - dActualSum
    If dDifference > 0 Then
        dDiff = dDiff1
    Else
        dDiff = dDiff2
        dAdj = -dAdj
        dDifference = -dDifference
    End If
        
    For i = 1 To dDifference / Abs(dAdj)
        For r = 1 To lRows
            For c = 1 To lCols
                If dDiff(r, c) = WorksheetFunction.Small(dDiff, i) Then
                    If Not bRoundedAlready(r, c) Then
                        v(r, c) = v(r, c) + dAdj
                        bRoundedAlready(r, c) = True
                        GoTo Success
                    End If
                End If
            Next c
        Next r
Success:
    Next i
    
    RoundToSum = v

End Function

 

[István Hirsch]

I did not enter the UDF correctly, now it works as your table shows. Thanks.