1 Тема от btm

  • btm
  • рядовой
  • Неактивен
  • Зарегистрирован: 18.04.2018
  • Сообщений: 5

Тема: Макрос для округления десятичных дробей

Здравствуйте! Имеется текст с десятичными дробями разной точности: от десятых до тысячных. Возможно ли создать макрос для автоматического поиска и округления всех дробей с трямя знаками после запятой до двух знаков после запятой? Но, так, что бы к имеющимся в тексте целым числам и дробям до десятых не приписались лишние знаки (ноли после запятой или сотой).

2 Ответ от Fck_This

  • Макрос для округления десятичных дробей
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97
  • За сообщение: 1

Re: Макрос для округления десятичных дробей

btm пишет:

Здравствуйте! Имеется текст с десятичными дробями разной точности: от десятых до тысячных. Возможно ли создать макрос для автоматического поиска и округления всех дробей с трямя знаками после запятой до двух знаков после запятой? Но, так, что бы к имеющимся в тексте целым числам и дробям до десятых не приписались лишние знаки (ноли после запятой или сотой).

Sub A_Округление_дробей()

' A_Округление_дробей Макрос
Dim oDoc As Document
Dim sChar As String
Set oDoc = ActiveDocument
Select Case MsgBox("Да - запятая" & vbCr & "Нет - точка" & vbCr & "Отмена - выход", vbYesNoCancel)
    Case vbYes: sChar = ","
    Case vbNo: sChar = "."
    Case vbCancel: Exit Sub
End Select
Selection.HomeKey Unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .Forward = True
    .MatchWildcards = True
    .Text = "[0-9]{1;}" & sChar & "[0-9]{3}"
    Do While .Execute = True
    If IsNumeric(Selection.Range.Characters.Last.Next) = False Then
        sText = fRoundedOff(Selection.Range.Text)
        Selection.Range.Text = sText
    End If
    Loop
End With
End Sub
Function fRoundedOff(ByVal sValue As String)
Dim iLast As Integer
Dim iNumber As Double
Dim iDif As Double
iNumber = CDbl(sValue)
iLast = CInt(Right(sValue, 1))
If iLast >= 5 Then
iDif = CDbl("0,00" & iLast)
iNumber = iNumber - iDif + 0.01
Else
iNumber = CDbl(Left(sValue, Len(sValue) - 1))
End If
fRoundedOff = iNumber
End Function
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

3 Ответ от btm

  • btm
  • рядовой
  • Неактивен
  • Зарегистрирован: 18.04.2018
  • Сообщений: 5

Re: Макрос для округления десятичных дробей

Спасибо за ответ!
Почему то макрос у меня не сработал, появляется окно:

4 Ответ от btm

  • btm
  • рядовой
  • Неактивен
  • Зарегистрирован: 18.04.2018
  • Сообщений: 5

Re: Макрос для округления десятичных дробей

btm пишет:

Спасибо за ответ!
Почему то макрос у меня не сработал, появляется окно:

Да - запятая, Нет - точка, Отмена - выход.

Жму да, ничего не происходит. Жму нет - пишет Run-time error 13, type mismatch. Жму debug - выделена желтым строка iNumber = CDbl (sValue)

5 Ответ от btm

  • btm
  • рядовой
  • Неактивен
  • Зарегистрирован: 18.04.2018
  • Сообщений: 5

Re: Макрос для округления десятичных дробей

Я забыл написать, что десятичные дроби в тексте в англоязычном варианте, т.е. не запятые, а точки. Например, не "0,345", а "0.345". А сам текст весь на русском языке. Спасибо!

6 Ответ от Fck_This

  • Макрос для округления десятичных дробей
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97
  • За сообщение: 1

Re: Макрос для округления десятичных дробей

Да, мой косяк. Класс Double использует для отделения дробной части запятую, а не точку - нужна поправка. Вот это будет работать 100%:

Sub A_Округление_дробей()
' vbadevelope@yandex.ru for wordexpert.ru
Dim oDoc As Document
Dim sChar As String
Set oDoc = ActiveDocument
Select Case MsgBox("Да - запятая" & vbCr & "Нет - точка" & vbCr & "Отмена - выход", vbYesNoCancel)
    Case vbYes: sChar = ","
    Case vbNo: sChar = "."
    Case vbCancel: Exit Sub
End Select
Selection.HomeKey Unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .Forward = True
    .MatchWildcards = True
    .Text = "[0-9]{1;}" & sChar & "[0-9]{3}"
    Do While .Execute = True
    If IsNumeric(Selection.Range.Characters.Last.Next) = False Then
        sText = fRoundedOff(Selection.Range.Text)
        Selection.Range.Text = sText
    End If
    Loop
End With
End Sub
Function fRoundedOff(ByVal sValue As String)
Dim iLast As Integer
Dim iNumber As Double
Dim iDif As Double
Dim bCheck As Boolean
If InStr(sValue, ".") >= 1 Then
    sValue = Replace(sValue, ".", ",")
    bCheck = True
Else
    bCheck = False
End If
iNumber = CDbl(sValue)
iLast = CInt(Right(sValue, 1))
If iLast >= 5 Then
iDif = CDbl("0,00" & iLast)
iNumber = iNumber - iDif + 0.01
Else
iNumber = CDbl(Left(sValue, Len(sValue) - 1))
End If
If bCheck = True Then
    fRoundedOff = Replace(iNumber, ",", ".")
Else
    fRoundedOff = iNumber
End If
End Function
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

7 Ответ от btm

  • btm
  • рядовой
  • Неактивен
  • Зарегистрирован: 18.04.2018
  • Сообщений: 5

Re: Макрос для округления десятичных дробей

Большое спасибо! Макрос работает!