使用 VBA 将 Round 函数插入当前单元格

Insert Round function into current cell using VBA

提问by user1050200

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

我试图更容易地将 Round 函数插入到许多已经包含公式的单元格中。

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+b2portion has to be anything.

例如，如果单元格 A1 具有公式=b1+b2，则在使用此宏后，我希望单元格内容读取 =Round(b1+b2,). 每个单元格中的公式都不相同，因此该b1+b2部分必须是任何内容。

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.

所以我真的在寻找某种方法来获取选定单元格中的公式，然后使用 VBA 编辑这些内容。我在任何地方都找不到答案。

回答by DontFretBrett

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

回答by brettdj

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

这是对brettville的做法基础的变化的代码，我在另一个论坛上写下的是

1. Works on all formula cells in the current selection

2. 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
   

1. 适用于当前选择中的所有公式单元格

2. 使用数组、SpecialCells 和字符串函数来优化速度。如果您有很多单元格，循环遍历范围可能会非常慢

   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
   

回答by Darryl Worth

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 ifstatement to check to see if there already is a "=round" formula to prevent someone from running more than once or rounding within a round.

第二个“ =round”函数的拼写错误是“ =Rround”。一旦用 2 轮而不是 1 轮修改后，这个过程对我来说效果很好。我可能会添加另一个if语句来检查是否已经有一个“ =round”公式来防止某人运行不止一次或在一轮内进行四舍五入。

Darryl

达里尔

回答by Sumit Saha

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

回答by ExcelinEfendisi

Try This

尝试这个

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

对于选择 N.formula="round (" & mid (n.formula,2,100) & ",1)" 中的每个 n 下一个 n

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

我假设您现有公式的长度小于 100 个字符且敏感度为 1。您可以更改这些值

回答by EREX

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

我改进了Sumit Saha提供的答案，以提供以下功能：

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

1. 用鼠标选择一个范围或不同的范围
2. 输入所需的位数而不是编辑代码
3. 输入通过更改iNum 的行顺序选择的不同区域的位数，如解释。

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