Insert Round function into current cell using VBA

问题

I'm trying to make it easier to insert the Round function into a number of cells that already have formulas in them.

For instance, if cell A1 has the formula =b1+b2, after the use of this macro, I want the cell contents to read =Round(b1+b2,). The formulas in each of the cells are not the same, so the b1+b2 portion has to be anything.

All I can get to is this:

Sub Round()

    Activecell.FormulaR1C1 = "=ROUND(b1+b2,)"     
End Sub

So I'm really looking for some way to get the formula in a selected cell, and then edit those contents using VBA. I can't find the answer anywhere.

回答1:

How about this?

Sub applyRound(R As Range)
    If Len(R.Formula) > 0 Then
        If Left(R.Formula, 1) = "=" Then
            R.Formula = "=round(" & Right(R.Formula, Len(R.Formula) - 1) & ",1)"
        End If
    End If
End Sub

回答2:

This is a variation on brettville's approach base on code I wrote on another forum that

Works on all formula cells in the current selection

Uses arrays, SpecialCells and string functions to optimise speed. Looping through ranges can be very slow if you have many cells

Sub Mod2()
Dim rng1 As Range
Dim rngArea As Range
Dim i As Long
Dim j As Long
Dim X()
Dim AppCalc As Long

On Error Resume Next
Set rng1 = Selection.SpecialCells(xlFormulas)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub

With Application
    AppCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

For Each rngArea In rng1.Areas
    If rngArea.Cells.Count > 1 Then
        X = rngArea.Formula
        For i = 1 To rngArea.Rows.Count
            For j = 1 To rngArea.Columns.Count
                X(i, j) = "=ROUND(" & Right$(X(i, j), Len(X(i, j)) - 1) & ",1)"
            Next j
        Next i
        rngArea = X
    Else
        rngArea.Value = "=Rround(" & Right$(rngArea.Formula, Len(rngArea.Formula) - 1) & ",1)"
    End If
Next rngArea

With Application
    .ScreenUpdating = True
    .Calculation = AppCalc
End With
End Sub

回答3:

Typo on the 2nd "=round" function was typed as "=Rround". Once modified with a round of 2, instead of 1, the process worked great for me. I may add in another if statement to check to see if there already is a "=round" formula to prevent someone from running more than once or rounding within a round.

Darryl

回答4:

The full modified program would be like this

    Sub Round_Formula()
    Dim c As Range
    Dim LResult As Integer
    Dim leftstr As String
    Dim strtemp As String
    Set wSht1 = ActiveSheet
    Dim straddress As String
    Dim sheet_name As String
    sheet_name = wSht1.Name
    'MsgBox (sheet_name)

    straddress = InputBox(Prompt:="Full cell Address where to insert round function as D8:D21", _
      Title:="ENTER Address", Default:="D8:D21")


    With Sheets(sheet_name)
    For Each c In .Range(straddress)
       If c.Value <> 0 Then
        strtemp = c.Formula
        'MsgBox (strtemp)
        LResult = StrComp(Left(strtemp, 7), "=ROUND(", vbTextCompare)
        'MsgBox ("The value of LResult is " & LResult)
        If LResult <> 0 Then
            'c.Formula = "=ROUND(" & Right(c.Formula, Len(c.Formula) - 1) & ",2)"
            c.Formula = "=ROUND(" & Right(c.Formula, Len(c.Formula) - 1) & ",0)"
        End If
    End If
Next c

End With
End Sub

回答5:

Try This

For each n in selection N.formula="round (" & mid (n.formula,2,100) & ",1)" Next n

I assumed your existing formula's length is less than 100 character and sensitivity is 1. You can change these values

回答6:

I have improved the answer provided by Sumit Saha, to provide the following features:

Select a range or different ranges with the mouse
Enter the number of digits desired instead of editing the code
Enter the number of digits for different regions selected by changing line order of iNum as explained.

Regards,

    Sub Round_Formula_EREX()
    Dim c As Range
    Dim LResult As Integer
    Dim leftstr As String
    Dim strtemp As String
    Set wSht1 = ActiveSheet
    Dim straddress As Range
    Dim iNum As Integer

    Set straddress = Application.Selection
    Set straddress = Application.InputBox("Range", xTitleId, straddress.Address, Type:=8)
    iNum = Application.InputBox("Decimal", xTitleId, Type:=1)

    For Each c In straddress
       If c.Value <> 0 Then
    strtemp = c.Formula

    LResult = StrComp(Left(strtemp, 7), "=ROUND(", vbTextCompare)

    If LResult <> 0 Then
    'If you want to enter different digits for different regions you have selected,
    'activate next line and deactivate previous iNum line.
    'iNum = Application.InputBox("Decimal", xTitleId, Type:=1)

     c.Formula = "=ROUND(" & Right(c.Formula, Len(c.Formula) - 1) & "," & iNum & ")"
      End If
     End If
    Next c

    End Sub

来源：https://stackoverflow.com/questions/8156109/insert-round-function-into-current-cell-using-vba

标签

excel

vba

cell

formula