Вставьте функцию Round в текущую ячейку, используя VBA

Question

Я пытаюсь упростить вставку функции Round в число ячеек, в которых уже есть формулы.

Например, если ячейка A1 имеет формулу =b1+b2, после использования этого макроса я хочу, чтобы содержимое ячейки читалось как =Round(b1+b2,). Формулы в каждой из ячеек не одинаковы, поэтому часть b1+b2 должна быть чем угодно.

Все, что я могу получить, это:

Sub Round()

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

Так что я действительно ищу способ получить формулу в выбранной ячейке, а затем отредактировать это содержимое с помощью VBA. Я нигде не могу найти ответ.

Answer 1

Как насчет этого?

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

Answer 2

Я улучшил ответ, предоставленный 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

Answer 3

Попробуйте

Для каждого n в выборе N.formula = "round (" & mid (n.formula, 2100) & ", 1)" Далее n

Я предположил, что длина вашей существующей формулы меньше 100 символов, а чувствительность равна 1. Вы можете изменить эти значения

Answer 4

Полностью измененная программа будет выглядеть так:

    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

Answer 5

Опечатка для 2-й функции "=round" была напечатана как "=Rround". После модификации с раундом 2 вместо 1 процесс работал отлично для меня. Я могу добавить еще один оператор if, чтобы проверить, существует ли уже формула "=round", которая запрещает кому-либо запускаться более одного раза или выполнять округление в течение раунда.

Дэррил

Answer 6

Это вариант подхода Бреттвилла к коду, который я написал на другом форуме , что

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