Changing rounded numbers to equal their sum

Question

In our financial statements we round everything to whole numbers and then sum them. Of course, the actual sum of the individual numbers does not always equal the summation of these numbers. I understand the reasons for this happening, but I want the rounded summation of the actual numbers to print and the component numbers to be "fudged" so that they equal the total. For example, if I have the numbers 5.20, 4.30, and 6.40 they are going to sum to 15.90. If I round them to a whole number I will obtain 5,4,and 6 and they will sum to 15. What I want is for the total to be 16 (the rounded summation of all of the component items) and the individual numbers to round to 5, 4, and 7 (fudged from 6.) Is there a way to accomplish this? Of course, my financial statements have thousands of numbers on them so I need some sort of formula that will work on all of them.

I have searched the Internet but can find nothing on this topic.

Thank you!

Answer 1

VBA approach without using any helper column

• Based on @CLR 's 'fudging' method +, I show you a fast VBA approach via datafield array allowing you to forget about any helper columns.
• Due to a later comment I edited a second approach => see II. Nearest roundings

I. First approach (based on CLR's method)

In my example I assume you have values in cells B2:B{n} including a last row with a total sum formula. In section (b) I create a one based 2-dim array, do some subsequent calculations and in section (g) I write the (redimmed) array v back to the same column B, but you can easily change that to any wanted column.

Method

The program logic is based on calculating the difference between i.) the rounded total sum and ii.) the sum of each individual rounding and a subsequent value correction. Roundings are effectuated to whole numbers via WorksheetFunction.Round() (as opposed to so called Banker's Rounding via VBA's Round function)

Code

Option Explicit
Public Sub Fudge()
  Dim v     As Variant
  Dim i     As Long, n As Long
  Dim total As Double, rounded As Double, diff As Double
  Dim d     As Double, m As Double
  Dim ws    As Worksheet, Rng As Range
  Set ws = ThisWorkbook.Worksheets("MySheet")   ' << change to your sheet name
' (a) get last row in column B containing data  '    (omitting last row with total sum!)
      n = ws.Range("B" & ws.Rows.Count).End(xlUp).row - 1 ' << subtract 1 if last sum row!
' (b) get values (col.B-data, col.C- for calculation) to one based 2dim array
      v = ws.Range("B2:C" & n).Value
' (c) loop through array to round (items count n - 1, as omitting one title row!)
      For i = 1 To n - 1
          v(i, 2) = WorksheetFunction.Round(v(i, 1), 0)
      Next i
' (d) calculate difference to sum of rounded values
      Set Rng = ws.Range("B2:B" & n)            '
      total = Application.Sum(Rng)
      rounded = Application.Sum(Application.Index(v, 0, 2))
      diff = WorksheetFunction.Round(total - rounded, 0)
      ' Debug.Print "Fudge Difference = WorksheetFunction.Round(" & total & " - " & rounded & ", 0) = " & Format(diff, "0.00;-0.00")
' (e) Loop through array and "fudge" (items count n - 1, as omitting one title row!)
      For i = 1 To n - 1
        ' get modifier
          m = IIf(d < diff, 1, 0)
        ' "fudge" values and cumulate modifiers
          v(i, 1) = v(i, 2) + m: d = d + m
      Next i
' (f) redim to one column only (items count n - 1, as omitting title row)
      ReDim Preserve v(1 To n - 1, 1 To 1)
' (g) write back to B (or to ANY wanted column :-)
      ws.Range("B2:B" & n).Value = v
End Sub

===== EDIT 1/17 2018 =======

II. Nearest roundings (cf. comment as of 16/1 2018)

This should meet your latest requirements to

"..change the items that rounded to $0.50 from the actual amount FIRST, then change the items that rounded off to either $0.51 or $0.49 from the actual amount, then those that round to $0.52 or $0.48, etc, etc. No number should be rounded by more than $0.99."

Method

The Program logic also calculates the difference between i.) the rounded total sum and ii.) the sum of each individual rounding, but uses a refined correction pattern.

Basically this 2nd approach uses a datafield array combined with some filtering methods based on a loop through the nearest absolute differences around $0.50 and a search for a special alphnumeric code combining these 50 differences with the item number.

Code

Option Explicit
Sub Fudge()
  Dim s As String
  Dim v, vx     As Variant
  Dim ii  As Long
  Dim total As Double, rounded As Double, diff As Double, diffrest As Double, cent As Double
  Dim i     As Long, j As Long, n As Long
  Dim ws    As Worksheet
  Set ws = ThisWorkbook.Worksheets("MySheet")   ' << change to your sheet name
' --------------------------------------------------------------------
' I.  Get data for normal roundings and code absolute cent differences
' --------------------------------------------------------------------
' (a) get last row in column B containing data  '    (omitting last row with total sum!)
      n = ws.Range("B" & ws.Rows.Count).End(xlUp).row - 1 ' << subtract 1 if last sum row!
' (b) get values (col.B-data, col.C-D temp) to one based 2dim array
      v = ws.Range("B2:D" & n).Value
      total = Application.Sum(Application.Transpose(Application.Index(v, 0, 1)))
' (c) loop through array to round (items count n - 1, as omitting one title row!)
      For i = 1 To n - 1
        ' round original values
          v(i, 2) = WorksheetFunction.Round(v(i, 1), 0)
        ' convert absolute cent differences 1-100 to chr codes and add item no
          v(i, 3) = Chr(64 + (0.51 - Abs(v(i, 2) - v(i, 1))) * 100) & _
                    Format(i, "0")   ' << corr./edited
        ' overwrite original data in col2 with rounded values col1, AFTER coding!
          v(i, 1) = v(i, 2)
      Next i
' --------------------------------------------------------------------
' II. Calculate 'fudge'
' --------------------------------------------------------------------
      rounded = Application.Sum(Application.Transpose(Application.Index(v, 0, 2)))
      diff = WorksheetFunction.Round(rounded - total, 0)    ' resting difference
      diffrest = diff
' --------------------------------------------------------------------
' III. 'Fudge' resting difference using Filter function
' --------------------------------------------------------------------
  For j = 0 To 49                      ' absolute cent differences 0 to 49
      If diffrest = 0 Then Exit For    ' escape if no diffrest left
      s = Chr(64 + j)                  ' code differences from Chr(64)="A" to Chr(64+49)="q"
  '  (a) get zerobased 1-dim array via ' Filter function
      vx = Filter(Application.Transpose(Application.Index(v, 0, 3)), s)
  '  (b) Adapt roundings nearest to .50, .49, to .99 cents (i.e. j = 0, 1 to 49)
      For i = LBound(vx) To UBound(vx) ' loop through filter items
           ii = Val("0" & Replace(vx(i), s, "")) ' get coded Item index from filter array
           If ii <> 0 Then
              If diffrest <> 0 Then    ' remaining diffrest
                 cent = IIf(diffrest > 0, -1, 1) ' get fudge cent
                 v(ii, 1) = v(ii, 2) + cent      ' << new value = rounded +/- 1 cent
                 diffrest = WorksheetFunction.Round(diffrest + cent, 0)
               ' check escape condition: no remaining diffRest
                 If diffrest = 0 Then Exit For
               End If
           End If
      Next i
  Next j
' --------------------------------------------------------------------
' IV. Write results
' --------------------------------------------------------------------
' (a) redim to one column only (items count n - 1, as omitting title row)
      ReDim Preserve v(1 To n - 1, 1 To 1)
' (b) write back to B (or to ANY wanted column :-)
      ws.Range("C2:C" & n).Value = v
End Sub

Note

Explications are added to the above code as comments. I assume that code starts in the second row (omitting the title row) and that there is a last row with a possible total sum or formula which is omitted, too.

Edit 1/22 2018 - Debug indicated code line

Due to your comment as of 22/1 try the following by inserting some Error handling in your I.c) loop:

    ' convert ...
      On Error Resume Next                                                       ' << EDIT 1/22 2018
      v(i, 3) = Chr(64 + (0.51 - Abs(v(i, 2) - v(i, 1))) * 100) & Format(i, "0") ' << code line in question
      If Err.Number <> 0 Then                                                    ' << EDIT 1/22 2018
         Debug.Print "Error No " & Err.Number & " " & Err.Description
         Debug.Print "i =" & i
         Debug.Print "v(" & i & ",1)=" & v(i, 1), "v(" & i & ",2)=" & v(i, 2)
         Debug.Print (0.51 - Abs(v(i, 2) - v(i, 1))) * 100
         v(i, 3) = 0
         Err.Clear
      End If
    ' overwrite ...   

Answer 2

Let's say you have column A with a header and then your values - 5.20, 4.30 and 6.40.

In column B you have a formula that rounds the column A value - =ROUND(A2,0), =ROUND(A3,0) and =ROUND(A4,0)

You'd then want a modifier column containing the following formula IN CELL C2:

=IF(SUM(C$1:C1)<ROUND(SUM(A:A),0)-SUM(B:B),1,0)

Copy the above down, and you'll see an additional 1 appear in each cell until it makes up the difference between the column A total and the rounded column B total.

Finally, a final column (D) to add B and C together will give you your required values. I've added another item but it might look something like this: