Вмъкнете Round функция в текущата клетка с помощта на VBA

Какво ще кажете за това?

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

Това е вариант на подхода на brettville, базиран на код, който написах в друг форум, който

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
   

Печатна грешка във втората функция "=round" беше въведена като "=Rround". Веднъж модифициран с кръг от 2, вместо 1, процесът работи чудесно за мен. Мога да добавя друг израз if, за да проверя дали вече има формула "=round", за да попреча на някой да изпълнява повече от веднъж или да закръгля в рамките на кръг.

Дарил

Пълната модифицирана програма ще бъде така

    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

Опитайте тази

За всяко n в селекцията N.formula="round (" & mid (n.formula,2,100) & ",1)" Next n

Предположих, че дължината на вашата съществуваща формула е по-малка от 100 знака и чувствителността е 1. Можете да промените тези стойности

Подобрих отговора, предоставен от Sumit Saha, за да предоставя следните функции:

1. Изберете диапазон или различни диапазони с мишката
2. Въведете желания брой цифри, вместо да редактирате кода
3. Въведете броя на цифрите за различни избрани региони, като промените реда на iNum, както е обяснено.

За разбирането,

    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