Rounding Numbers with VBA

vaxo
4StarLounger
Posts: 432
Joined: 23 Mar 2017, 19:51

Rounding Numbers with VBA

Post by vaxo »

Hello Friends, I have Vba macro for rounding cells, but it does it on the entire sheet, I need to change this macro so then the selection method was to be applied. Please help.

Code: Select all

Sub rRoundIt()
Dim rng As Range
Dim rngArea As Range
Dim AppCalc As Long
On Error Resume Next
With Application
    AppCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Set rng = Union(Selection.SpecialCells(xlCellTypeFormulas, xlNumbers), _
                Selection.SpecialCells(xlCellTypeConstants, xlNumbers))
For Each rngArea In rng
    If Left(rngArea.Formula, 7) <> "=ROUND(" Then _
        rngArea.Formula = "=ROUND(" & Replace(rngArea.Formula, Chr(61), vbNullString) & ", 1)"
Next rngArea
With Application
    .ScreenUpdating = True
    .Calculation = AppCalc
End With
End Sub

User avatar
HansV
Administrator
Posts: 78233
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Rounding Numbers with VBA

Post by HansV »

As far as I can tell, it only affects cells outside the selection if the selection is a single cell.
And the code will mess up the formula if it contains = characters apart from the first character: they would be removed.
For example, the formula

=IF(A1=0,"",A1)

would become

=ROUND(IF(A10,"",A1),0)

See if this works for you:

Code: Select all

Sub rRoundIt()
    Dim rng As Range
    Dim rngArea As Range
    Dim AppCalc As Long
    On Error Resume Next
    With Application
        AppCalc = .Calculation
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    If Selection.CountLarge = 1 Then
        Set rng = ActiveCell
    Else
        Set rng = Union(Selection.SpecialCells(xlCellTypeFormulas, xlNumbers), _
                        Selection.SpecialCells(xlCellTypeConstants, xlNumbers))
    End If
    For Each rngArea In rng
        If rngArea.HasFormula Then
            If Left(rngArea.Formula, 7) <> "=ROUND(" Then
                rngArea.Formula = "=ROUND(" & Mid(rngArea.Formula, 2) & ", 1)"
            End If
        Else
            rngArea.Formula = "=ROUND(" & rngArea.Value & ", 1)"
        End If
    Next rngArea
    With Application
        .ScreenUpdating = True
        .Calculation = AppCalc
    End With
End Sub
Best wishes,
Hans

vaxo
4StarLounger
Posts: 432
Joined: 23 Mar 2017, 19:51

Re: Rounding Numbers with VBA

Post by vaxo »

Yes, but when there is no formula in the sheet the code does not execute? why?

User avatar
HansV
Administrator
Posts: 78233
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Rounding Numbers with VBA

Post by HansV »

Here is an improved version:

Code: Select all

Sub rRoundIt()
    Dim rng As Range
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rngArea As Range
    Dim AppCalc As Long
    On Error Resume Next
    With Application
        AppCalc = .Calculation
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    If Selection.CountLarge = 1 Then
        If Application.IsNumber(ActiveCell) Then
            Set rng = ActiveCell
        End If
    Else
        Set rng1 = Selection.SpecialCells(xlCellTypeFormulas, xlNumbers)
        Set rng2 = Selection.SpecialCells(xlCellTypeConstants, xlNumbers)
        If rng1 Is Nothing Then
            If rng2 Is Nothing Then
                ' Nothing to do
            Else
                Set rng = rng2
            End If
        Else
            If rng2 Is Nothing Then
                Set rng = rng1
            Else
                Set rng = Union(rng1, rng2)
            End If
        End If
    End If
    For Each rngArea In rng
        If rngArea.HasFormula Then
            If Left(rngArea.Formula, 7) <> "=ROUND(" Then
                rngArea.Formula = "=ROUND(" & Mid(rngArea.Formula, 2) & ", 1)"
            End If
        Else
            rngArea.Formula = "=ROUND(" & rngArea.Value & ", 1)"
        End If
    Next rngArea
    With Application
        .ScreenUpdating = True
        .Calculation = AppCalc
    End With
End Sub
Best wishes,
Hans

vaxo
4StarLounger
Posts: 432
Joined: 23 Mar 2017, 19:51

Re: Rounding Numbers with VBA

Post by vaxo »

Thaks it works great...