Round to nearest in Excel with VBA macros
You might need to round to the nearest 1000 (or whatever). It may be rounding 77 to 80, 315 to 400, 1777 to 2000 etc. On this page I show how to do it with a VBA macro.
The other day I needed the functionality for automatic scaling of a chart's Y axis. Selecting automatic scaling was no good, because the chart was animated, and it would look stupid, if the Y axis changed constantly as the bar grew higher.
I solved the problem by calculating the final value and scaling the Y axis before I started the loopdriven animation. The function rounding to nearest whole number (e.g. 70), 100, 1000 etc. follows below.
It would be simple if you always needed to round up to the nearest thousand. Then you could use the following code snippet, where I assume that the input value is 1777:
Rounded value = Fix(1777 / 1000) * 1000 + 1000
However it is not that simple, if the input value can be anything. Then you need a more robust code that will make a sensible scaling no matter if the value is 2, 77 or 18,374.37.
If you want to test the code just copy it into a VBA module. As it is a function, it returns a value and must be called from another function or procedure passing the input value.
There is a procedure example at the bottom of the page.
Function NearestRoundValue(ByVal dInputVal As Double)
Dim lRoundVal As Long
Dim lFactor As Long
Dim lValLenght As Long
Dim lLoop As Long
Dim sNb As String
On Error GoTo ErrorHandle
lRoundVal = Round(Abs(dInputVal))
lValLenght = Len(Trim(Str$(lRoundVal)))  1
sNb = "1"
For lLoop = 1 To lValLenght
sNb = sNb & "0"
Next
lFactor = Val(sNb)
lRoundVal = Fix(lRoundVal / lFactor) * lFactor + lFactor
If dInputVal < 0 Then
lRoundVal = lRoundVal * 1
End If
NearestRoundValue = lRoundVal
Exit Function
ErrorHandle:
MsgBox Err.Description
End Function
And here is an example procedure that calls the function above passing the input value. It displays the returned value (200000) in a messagebox. In real life the input value would probably be calculated or read from the spreadsheet.
Sub Test()
MsgBox NearestRoundValue(183575.88)
End Sub
