强制舍入以等于总和

时间:2018-01-24 13:30:17

标签: vba excel-vba rounding excel-2013 excel

我在一家大型公司工作,该公司在其财务报表中提供舍入数字。当然,舍入数字并不总是等于总数。我希望将最接近$ 0.50的组件编号向上或向下舍入,以使列等于总数。

例如,如果我有数字5.43,4.26和6.32,它们总共16.01。圆形,它们将分别为5,4和6,总数将为15.我希望将总数舍入为16,最接近$ X.50以绕过必要的方式。在这种情况下,它将是5.43舍入到6而不是5.

T.M.为我编写了以下代码。它适用于他的机器,但不适用于我的机器。他正在使用 Excel 2010 ,而我正在使用 Excel 2013 。每当我尝试执行代码时,都会出现错误,表示

  

编译错误:参数数量错误或属性分配无效。

单击“确定”按钮后,调试器会以蓝色突出显示单词Format。突出显示的单词Format位于第I部分c)End If命令之前的代码行中。

当我尝试测试代码时,我使用的是870金额的列,总计的总金额是实际总额的21.44美元。这意味着我需要将870个数字中的21个或22个用“错误”方式四舍五入。如果有人能提出解决方案,我将非常感激。谢谢!

Sub MurrayRound()
'
' MurrayRound Macro
' Rounds Murray's figures for budget.
  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("Rick")   ' << 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")

      End If

        ' 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

0 个答案:

没有答案