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

Question

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

我搜索了互联网，但却找不到这个主题。

谢谢！

Answer 1

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

在B列中，您有一个对A列进行舍入的公式 - =ROUND(A2,0)，=ROUND(A3,0)和=ROUND(A4,0)

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

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

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

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

Answer 2

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

• 基于@CLR的'捏造'方法 +，我通过数据字段数组向您展示快速VBA方法，让您忘记任何帮助列。
• 由于后来的评论，我编辑了第二种方法=＆gt; 见 II。最近的舍入

  

<强>予。第一种方法（基于CLR的方法）

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

方式

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

<强>代码

Round

  

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

<强> II。最近的舍入（参见截至2011年1月16日的评论）

这应符合您对

的最新要求

  

“..从实际金额FIRST更改四舍五入到$ 0.50的项目，然后将四舍五入的项目从实际金额更改为$ 0.51或$ 0.49，然后将那些舍入到$ 0.52或$ 0.48等的项目等等。数字应该四舍五入超过0.99美元。“

方式

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

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

<强>代码

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

注意

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

  

编辑2018年1月22日 - 调试指示的代码行

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

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