将舍入数字更改为等于其总和

Question

在我们的财务报表中，我们将所有内容都整数转换为整数，然后求它当然，各个数字的实际总和并不总是等于这些数字的总和。我理解发生这种情况的原因，但我想要打印实际数字的四舍五入和组件数量“捏造”，以便它们等于总数。例如，如果我有数字5.20,4.30和6.40，它们将总和为15.90。如果我将它们四舍五入到整数，我将获得5,4和6，它们将总和为15.我想要的是总数为16（所有组件项的舍入总和）和单个数字到转到5,4和7（从6开始捏造）有没有办法实现这一目标？当然，我的财务报表上有数千个数字，所以我需要一些适用于所有这些数字的公式。

我已经搜索过互联网，但却找不到这个话题。

谢谢！

Answer 1

不使用任何帮助列的VBA方法

• 基于@CLR的'fudging'方法+，我通过数据字段数组向您展示了一种快速的VBA方法，允许您忘记任何辅助列。
• 由于后来的评论，我编辑了第二种方法=>见II。最近的舍入

I.第一种方法（基于CLR的方法）

在我的例子中，我假设你在单元格B2:B{n}中有值，包括具有总和公式的最后一行。在（b）部分，我创建了一个基于2的dim数组，进行了一些后续计算，在（g）部分中，我将（redimmed）数组v写回到同一列B，但是您可以轻松地将其更改为任何想要的列。

方法

程序逻辑基于计算i。）舍入的总和和ii。）每个单独舍入和随后的值校正之和之间的差异。通过WorksheetFunction.Round()实现舍入到整数（与通过VBA的Round函数所谓的Banker's Rounding相反）

码

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

=====编辑2011年1月17日=======

II。最近的舍入（参见截至201/1 2018年的评论）

这应该符合您的最新要求

“..改变从实际金额首次四舍五入至0.50美元的项目，然后将四舍五入的项目从实际金额更改为0.51美元或0.49美元，然后将那些舍入到0.52美元或0.48美元等等的项目更改为等号。四舍五入超过0.99美元。“

方法

程序逻辑还计算i。）舍入的总和和ii。）每个单独舍入的总和之间的差异，但使用精确的校正模式。

基本上，第二种方法使用数据域阵列结合一些基于循环的过滤方法，通过最接近0.50美元的绝对差异，并搜索将这50个差异与项目编号组合在一起的特殊字母数字代码。

码

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

注意

将解释作为注释添加到上面的代码中。我假设代码从第二行开始（省略标题行），并且最后一行有可能的总和或公式也被省略。

编辑1/22 2018 - 调试指示的代码行

由于您在22/1的评论，请在I.c）循环中插入一些错误处理，尝试以下操作：

    ' 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

假设您的A列带有标题，然后是您的值 - 5.20，4.30和6.40。

在B列中，您有一个圆柱A值的公式 - =ROUND(A2,0)，=ROUND(A3,0)和=ROUND(A4,0)

然后，您需要一个包含以下公式IN CELL C2的修饰符列：

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

将上面的内容复制下来，你会看到每个单元格中出现一个额外的1，直到它弥补了A列总数和圆柱B总数之间的差异。

最后，将B和C一起添加到最后一列（D）将为您提供所需的值。我添加了另一个项目，但它可能看起来像这样：