Changing rounded numbers to equal their sum - excel

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: