Теперь не хуже калькулятора. Округление копеек.

Public Sub Точность_как_на_Экране()
 
    With ActiveWorkbook
 
        Select Case MsgBox("Сейчас = " _
                         & IIf(.PrecisionAsDisplayed, "ВКЛючена", "ОТключена") _
                         & vbCrLf & "" _
                         & vbCrLf & "Да = Переключить!" _
                         & vbCrLf & "" _
                         & vbCrLf & "Нет = Оставить как есть" _
             , vbYesNo Or vbQuestion Or vbDefaultButton1, "Точность как на Экране")
 
            Case vbYes
                .PrecisionAsDisplayed = Not _
                                        .PrecisionAsDisplayed
            Case vbNo
                ' ничего
        End Select
 
    End With
 
    Application.Calculate
End Sub
 
Private Sub Диапазон_Формулы_Обернуть_Формулой_test()
    Dim iLeft As String, iRight As String
    iLeft = "=ROUND("
    iRight = ",2)"
    Диапазон_Формулы_Обернуть_Формулой Selection, iLeft, iRight
End Sub
 
Public Sub Диапазон_Формулы_Обернуть_Формулой(rng As Range, _
                                     ByVal iLeft As String, _
                                     ByVal iRight As String)
' Может пригодится для контроля округления копеек
 
    If Диапазон_Формулы_Наличие(rng) Then
 
        Set rng = rng.SpecialCells(xlCellTypeFormulas)
 
        Dim eL As Range, str_Formula As String
 
        For Each eL In rng
 
            With eL
 
                str_Formula = _
                Replace$(.FormulaR1C1, "=", vbNullString, 1)
 
                .Formula = iLeft & str_Formula & iRight
            End With
        Next
    End If
End Sub
 
Private Sub Диапазон_Округление_Убрать_test()
 
    Диапазон_Округление_Убрать Selection
End Sub
 
Public Sub Диапазон_Округление_Убрать(rng As Range)
 
    If Диапазон_Формулы_Наличие(rng) Then
 
        Dim iLeft As String, iRight As String
        iLeft = "=ROUND("
        iRight = ",2)"
 
        Dim eL As Range, str_Formula As String
 
        'FormulaR1C1 = "=ROUND(RC[-2]*RC[-1],2)"
 
        For Each eL In rng
 
            With eL
 
                str_Formula = .FormulaR1C1
 
                If left$(str_Formula, 7) = iLeft And _
                   Right$(str_Formula, 3) = iRight Then
 
                    str_Formula = _
                    Replace$(str_Formula, iLeft, vbNullString, 1)
 
                    str_Formula = _
                    left$(str_Formula, Len(str_Formula) - Len(iRight))
 
                    .Formula = "=" & str_Formula
                End If
            End With
        Next
    End If
End Sub
 
Public Function Диапазон_Формулы_Наличие(ByVal rng As Range) As Boolean
 
    On Error Resume Next
 
    If rng.SpecialCells(xlCellTypeFormulas).Count < 1 Then
 
        Диапазон_Формулы_Наличие = False
    Else
 
        Диапазон_Формулы_Наличие = True
    End If
End Function

 

Оставить комментарий

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.