Сумма прописью в Word - Как допилить? - Страница 2 - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Сумма прописью в Word - Как допилить? - Страница 2 - Мир MS Excel

Старая форма входа

Страница 2 из 3 « 1 2 3 »
Модератор форума: _Boroda_, китин

Сумма прописью в Word - Как допилить? (Word)

Сумма прописью в Word - Как допилить?

Дата: Четверг, 31.10.2013, 07:22 | Сообщение № 21

Группа: Друзья

Ранг: Старожил

Сообщений: 1762

Репутация: 501 ±

Замечаний: 0% ±

2003 & 2010

Цитата Alex_ST, 30.10.2013 в 19:22, в сообщении № 20

ты бы хоть полный текст процедуры выложил

А это и был полный текст процедуры - достаточно его в sub ... end sub заключить

Цитата Alex_ST, 30.10.2013 в 19:22, в сообщении № 20

Это что, у вас в бюстгалтерии так принято

О, ты не представляешь, сколько ещё олдскул-спецов попадается. И я их не виню - есть регламенты оформления, которые иногда просто не меняются.
Да и вообще, например, ты платежные поручения видел? Через какой разделитель там копейки?

Кроме того, запись суммы "по-русски", через запятую - приводит к ошибкам при преобразовании через Val()/CDbl() - ибо для VBA стандартным разделителем является точка.

Skype: andre.tm.007
Donate: Qiwi: 9517375010

Ответить

Дата: Понедельник, 20.01.2014, 23:09 | Сообщение № 22

Группа: Гости

Самая грамотная тема в интернете по данному вопросу!
Уважаемые камрады, помогите в решении следующего вопроса. У меня много договоров. Как правило суммы в миллионах, иногда в миллиардах, без копеек. Я хотел бы, чтобы, когда я меняю сумму договора, чтобы сумма прописью в скобочках возле числа автоматически переписывалась. Например. Беру я за болванку старый договор, там старая сумма и пропись соответственно тоже, я вписываю новую сумму, в пропись автоматом переписывается, как в excele. Я прошу расписать все как для дебила, потому что я не программист, и мне тяжко сразу врубиться в ньюансы. Хотя макрос AndreTM я запустил и все заработало.

Ответить

Дата: Среда, 22.01.2014, 21:43 | Сообщение № 23

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3214

Репутация: 615 ±

Замечаний: 0% ±

2003

Цитата Алексей, 20.01.2014 в 23:09, в сообщении № 22

макрос AndreTM я запустил и все заработало

А мой не заработал что ли?
Да и Вы же сами пишете

Цитата Алексей, 20.01.2014 в 23:09, в сообщении № 22

суммы в миллионах, иногда в миллиардах

а тот, что предложил AndreTM, может только до 999 999

Ну, а сделать в Word'e автоматически пересчитываемые формулы как в Excel'e - это моя давняя и, похоже, несбыточная мечта

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

Дата: Пятница, 24.01.2014, 13:26 | Сообщение № 24

Группа: Гости

Я сначала с Вашим пытался. у меня не получилось. Я видимо, что-то перепутал, так как не разобрался, как из двух Ваших постов сделать один макрос.
А макрос AndreTM успешно сделал мне 16550200.
Жаль, что нельзя сделать автоматическое пересчитывание.

Ответить

Дата: Вторник, 29.04.2014, 14:42 | Сообщение № 25

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3214

Репутация: 615 ±

Замечаний: 0% ±

2003

Специально для metrolog, задавшего вопрос не в той теме, и для других малоопытных написал инструкцию.
В стандартном модуле шаблона Normal.dot прописываете процедуры:[vba]

Код

Sub ПРОПИСЬЮ()
'---------------------------------------------------------------------------------------
' Procedure    : ПРОПИСЬЮ
' Author       : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL    : http://www.excelworld.ru/forum/4-6947-1
' DateTime     : 29.10.2013, 17:19
' Purpose      : цифры из выделенного текста перевести в число прописью и вставить после выделения
' Notes        :
'---------------------------------------------------------------------------------------
       If Selection.Type <> wdSelectionNormal Then Exit Sub
       Dim NNN
       With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = .Replace(Selection.Range.Text, ""): End With
       'If Len(NNN) Then Selection.MoveRight Unit:=wdWord: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "
       If Len(NNN) Then Selection.Start = Selection.End: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------  ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#)   ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
       Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
       If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
       sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
       des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
       nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
       ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
       RAZR = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "", "", "")
       rub = Left(Format(ЧИСЛО, "000000000000000.00"), 15)
       kop = Right(Format(ЧИСЛО, "0.00"), 2)
       If CDbl(rub) = 0 Then m = "ноль "
       For i = 1 To Len(rub) Step 3
          If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
             m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                       des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                       IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
          End If
       Next i
       СУМ_ПРОП = UCase(Left(m, 1)) & Mid(m, 2)
End Function

[/vba]
После этого на листе выделяете выделяете цифры и вызываете макрос ПРОПИСЬЮ

Специально для metrolog, задавшего вопрос не в той теме, и для других малоопытных написал инструкцию.
В стандартном модуле шаблона Normal.dot прописываете процедуры:[vba]

Код

Sub ПРОПИСЬЮ()
'---------------------------------------------------------------------------------------
' Procedure    : ПРОПИСЬЮ
' Author       : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL    : http://www.excelworld.ru/forum/4-6947-1
' DateTime     : 29.10.2013, 17:19
' Purpose      : цифры из выделенного текста перевести в число прописью и вставить после выделения
' Notes        :
'---------------------------------------------------------------------------------------
       If Selection.Type <> wdSelectionNormal Then Exit Sub
       Dim NNN
       With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = .Replace(Selection.Range.Text, ""): End With
       'If Len(NNN) Then Selection.MoveRight Unit:=wdWord: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "
       If Len(NNN) Then Selection.Start = Selection.End: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------  ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#)   ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
       Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
       If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
       sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
       des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
       nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
       ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
       RAZR = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "", "", "")
       rub = Left(Format(ЧИСЛО, "000000000000000.00"), 15)
       kop = Right(Format(ЧИСЛО, "0.00"), 2)
       If CDbl(rub) = 0 Then m = "ноль "
       For i = 1 To Len(rub) Step 3
          If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
             m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                       des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                       IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
          End If
       Next i
       СУМ_ПРОП = UCase(Left(m, 1)) & Mid(m, 2)
End Function

[/vba]
После этого на листе выделяете выделяете цифры и вызываете макрос ПРОПИСЬЮAlex_ST

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Вторник, 29.04.2014, 14:49

Ответить

СообщениеСпециально для metrolog, задавшего вопрос не в той теме, и для других малоопытных написал инструкцию.
В стандартном модуле шаблона Normal.dot прописываете процедуры:[vba]

Код

Sub ПРОПИСЬЮ()
'---------------------------------------------------------------------------------------
' Procedure    : ПРОПИСЬЮ
' Author       : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL    : http://www.excelworld.ru/forum/4-6947-1
' DateTime     : 29.10.2013, 17:19
' Purpose      : цифры из выделенного текста перевести в число прописью и вставить после выделения
' Notes        :
'---------------------------------------------------------------------------------------
       If Selection.Type <> wdSelectionNormal Then Exit Sub
       Dim NNN
       With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = .Replace(Selection.Range.Text, ""): End With
       'If Len(NNN) Then Selection.MoveRight Unit:=wdWord: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "
       If Len(NNN) Then Selection.Start = Selection.End: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------  ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#)   ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
       Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
       If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
       sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
       des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
       nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
       ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
       RAZR = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "", "", "")
       rub = Left(Format(ЧИСЛО, "000000000000000.00"), 15)
       kop = Right(Format(ЧИСЛО, "0.00"), 2)
       If CDbl(rub) = 0 Then m = "ноль "
       For i = 1 To Len(rub) Step 3
          If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
             m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                       des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                       IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
          End If
       Next i
       СУМ_ПРОП = UCase(Left(m, 1)) & Mid(m, 2)
End Function

[/vba]
После этого на листе выделяете выделяете цифры и вызываете макрос ПРОПИСЬЮ

Автор - Alex_ST
Дата добавления - 29.04.2014 в 14:42

Дата: Среда, 30.04.2014, 12:04 | Сообщение № 26

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Alex_ST, записал Ваш макрос. При попытке выполнить его, выдает ошибку. Помогите её устранить пожалуйста))) Скрин ошибки прилагаю

К сообщению приложен файл: Error.rar (89.8 Kb)

Ответить

Дата: Среда, 30.04.2014, 12:19 | Сообщение № 27

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Сравните
[vba]

Код

If Len(NNN) Then Selection.Start = Selection.End: Selection.Range.Text = " (" & СУМ_ПРОП(NNN) & ") "

[/vba]
и стоку на вашей картинке

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Среда, 30.04.2014, 12:24 | Сообщение № 28

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Прошу прощения, разобрался сам hands

hands

Похоже я начал понимать что и как!!!

Ответить

Дата: Понедельник, 28.12.2015, 11:43 | Сообщение № 29

Группа: Пользователи

Ранг: Новичок

Сообщений: 21

Репутация: 0 ±

Замечаний: 20% ±

Excel 2010

Уважаемый Alex_ST! Макрос, предложенный Вами, сумму в рублях 8309931,01 выдает в виде "(Восемьсот тридцать миллионов девятьсот девяносто три тысячи двести один )". Помогите разобраться с ошибкой!

Сообщение отредактировал рамиля - Понедельник, 28.12.2015, 11:50

Ответить

Дата: Понедельник, 28.12.2015, 18:25 | Сообщение № 30

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

рамиля, замените в коде

Код

"\D"

на

Код

"[^\d,]"

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Ответить

Дата: Вторник, 29.12.2015, 08:07 | Сообщение № 31

Группа: Пользователи

Ранг: Новичок

Сообщений: 21

Репутация: 0 ±

Замечаний: 20% ±

Excel 2010

Спасибо krosav4ig! Замену в коде сделала! Целая часть считывается правильно. Но, что нужно поменять в коде для считывания в виде "Восемь миллионов триста девять тысяч девятьсот тридцать два рубля 01 копейка"?

Сообщение отредактировал рамиля - Вторник, 29.12.2015, 08:32

Ответить

Дата: Вторник, 29.12.2015, 11:07 | Сообщение № 32

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

В функции из сообщения 25 вывод копеек отключен.
Используйте полный вариант функции (сообщение 4)

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Четверг, 08.12.2016, 13:08 | Сообщение № 33

Группа: Пользователи

Ранг: Новичок

Сообщений: 24

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Друзья, подскажите, можно ли внести изменения в макрос так, чтобы в конце не было пробела перед скобкой?
Например 1'000: получается (Одна тысяча ), хотелось бы (Одна тысяча)
Заранее спасибо)

использую из сообщения 25

Сообщение отредактировал iam_alex - Четверг, 08.12.2016, 13:08

Ответить

Дата: Четверг, 08.12.2016, 14:38 | Сообщение № 34

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

iam_alex, [vba]

Код

UCase(Left(m, 1)) & Mid(m, 2)

[/vba] замените на [vba]

Код

RTrim(UCase(Left(m, 1)) & Mid(m, 2))

[/vba]

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Ответить

Дата: Четверг, 08.12.2016, 15:28 | Сообщение № 35

Группа: Пользователи

Ранг: Новичок

Сообщений: 24

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

krosav4ig, спасибо!!!

Ответить

Дата: Понедельник, 16.01.2017, 12:46 | Сообщение № 36

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198

Репутация: 901 ±

Замечаний: 0% ±

Excel 2010, 2016

Naminator, оформите код тегами (кнопка #)

ЯД: 410013299366744 WM: R193491431804

Ответить

Дата: Вторник, 17.01.2017, 17:18 | Сообщение № 37

Группа: Пользователи

Ранг: Прохожий

Сообщений: 1

Репутация: 0 ±

Замечаний: 0% ±

Excel 2003

Исправил под свою задачу.
Сумму необходимо вводить с копейками, копейки указывать в двухзначном формате!
Строка "1201" либо "120,1" либо "12,01" преобразуется одинаково в "12 рублей 01 копейку", т.е. макрос удаляет все разделительные знаки,
затем последние два числа берет как копейки, остальное - рубли.
Максимальное значение 999999999999999,99 (999 триллионов)

Пример:
выделяем 12887,03руб., результат (Двенадцать тысяч восемьсот восемьдесят семь) рублей 03 копейки

[vba]

Код

Sub ПРОПИСЬЮ()
'---------------------------------------------------------------------------------------
' Procedure    : ПРОПИСЬЮ
' Author       : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL    : http://www.excelworld.ru/forum/4-6947-1
' DateTime     : 29.10.2013, 17:19
' Purpose      : цифры из выделенного текста перевести в число прописью и вставить после выделения
' Notes        : Копейки вводить обязательно в двухзначном формате т.к. они берутся из расчета последние 2 числа
' Пример       : Строка "1201" либо "120,1" либо "12,01" преобразуется одинаково в "12 рублей 01 копейку"
'---------------------------------------------------------------------------------------
    If Selection.Type <> wdSelectionNormal Then Exit Sub
    Dim NNN, NNNOst, NNNLen
    With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = .Replace(Selection.Range.Text, ""): End With
    NNNLen = Len(NNN)
    If NNNLen > 17 Then Exit Sub
    NNNOst = Format(Right(NNN, 2), "00", 2)
    If NNNLen > 2 Then NNN = Left(NNN, NNNLen - 2) Else NNN = 0
    ' NNN = NNN & "," & NNNOst
    If Len(NNN) Then Selection.Start = Selection.End: Selection.Range.Text = " (" & СУМ_ПРОП(NNN, NNNOst)
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------  ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#, ByVal ЧИСЛОКОП#)  ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
    Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
    If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
    sot = Array("", " сто", " двести", " триста", " четыреста", " пятьсот", " шестьсот", " семьсот", " восемьсот", " девятьсот")
    des = Array("", "", " двадцать", " тридцать", " сорок", " пятьдесят", " шестьдесят", " семьдесят", " восемьдесят", " девяносто")
    nadc = Array(" десять", " одиннадцать", " двенадцать", " тринадцать", " четырнадцать", " пятнадцать", " шестнадцать", " семнадцать", " восемнадцать", " девятнадцать")
    ed = Array("", " один", " два", " три", " четыре", " пять", " шесть", " семь", " восемь", " девять", "", " одна", " две")
    RAZR = Array(" триллион", " триллиона", " триллионов", " миллиард", " миллиарда", " миллиардов", " миллион", " миллиона", " миллионов", " тысяча", " тысячи", " тысяч", ") рубль ", ") рубля ", ") рублей ")
    rub = Left(Format(ЧИСЛО, "000000000000000"), 15)
    kop = Left(Format(ЧИСЛОКОП, "00"), 2)
    If CDbl(rub) = 0 Then m = " ноль"
    For i = 1 To Len(rub) Step 3
        If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
            m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                    des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                    IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
        End If
    Next i
    m = LTrim(m)
    СУМ_ПРОП = UCase(Left(m, 1)) & Mid(m, 2) & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек", IIf(kop Mod 10 = 1, "йка", "йки"))
End Function

[/vba]

Исправил под свою задачу.
Сумму необходимо вводить с копейками, копейки указывать в двухзначном формате!
Строка "1201" либо "120,1" либо "12,01" преобразуется одинаково в "12 рублей 01 копейку", т.е. макрос удаляет все разделительные знаки,
затем последние два числа берет как копейки, остальное - рубли.
Максимальное значение 999999999999999,99 (999 триллионов)

Пример:
выделяем 12887,03руб., результат (Двенадцать тысяч восемьсот восемьдесят семь) рублей 03 копейки

[vba]

Код

Sub ПРОПИСЬЮ()
'---------------------------------------------------------------------------------------
' Procedure    : ПРОПИСЬЮ
' Author       : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL    : http://www.excelworld.ru/forum/4-6947-1
' DateTime     : 29.10.2013, 17:19
' Purpose      : цифры из выделенного текста перевести в число прописью и вставить после выделения
' Notes        : Копейки вводить обязательно в двухзначном формате т.к. они берутся из расчета последние 2 числа
' Пример       : Строка "1201" либо "120,1" либо "12,01" преобразуется одинаково в "12 рублей 01 копейку"
'---------------------------------------------------------------------------------------
    If Selection.Type <> wdSelectionNormal Then Exit Sub
    Dim NNN, NNNOst, NNNLen
    With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = .Replace(Selection.Range.Text, ""): End With
    NNNLen = Len(NNN)
    If NNNLen > 17 Then Exit Sub
    NNNOst = Format(Right(NNN, 2), "00", 2)
    If NNNLen > 2 Then NNN = Left(NNN, NNNLen - 2) Else NNN = 0
    ' NNN = NNN & "," & NNNOst
    If Len(NNN) Then Selection.Start = Selection.End: Selection.Range.Text = " (" & СУМ_ПРОП(NNN, NNNOst)
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------  ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#, ByVal ЧИСЛОКОП#)  ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
    Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
    If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
    sot = Array("", " сто", " двести", " триста", " четыреста", " пятьсот", " шестьсот", " семьсот", " восемьсот", " девятьсот")
    des = Array("", "", " двадцать", " тридцать", " сорок", " пятьдесят", " шестьдесят", " семьдесят", " восемьдесят", " девяносто")
    nadc = Array(" десять", " одиннадцать", " двенадцать", " тринадцать", " четырнадцать", " пятнадцать", " шестнадцать", " семнадцать", " восемнадцать", " девятнадцать")
    ed = Array("", " один", " два", " три", " четыре", " пять", " шесть", " семь", " восемь", " девять", "", " одна", " две")
    RAZR = Array(" триллион", " триллиона", " триллионов", " миллиард", " миллиарда", " миллиардов", " миллион", " миллиона", " миллионов", " тысяча", " тысячи", " тысяч", ") рубль ", ") рубля ", ") рублей ")
    rub = Left(Format(ЧИСЛО, "000000000000000"), 15)
    kop = Left(Format(ЧИСЛОКОП, "00"), 2)
    If CDbl(rub) = 0 Then m = " ноль"
    For i = 1 To Len(rub) Step 3
        If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
            m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                    des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                    IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
        End If
    Next i
    m = LTrim(m)
    СУМ_ПРОП = UCase(Left(m, 1)) & Mid(m, 2) & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек", IIf(kop Mod 10 = 1, "йка", "йки"))
End Function

[/vba]Naminator

Ответить

СообщениеИсправил под свою задачу.
Сумму необходимо вводить с копейками, копейки указывать в двухзначном формате!
Строка "1201" либо "120,1" либо "12,01" преобразуется одинаково в "12 рублей 01 копейку", т.е. макрос удаляет все разделительные знаки,
затем последние два числа берет как копейки, остальное - рубли.
Максимальное значение 999999999999999,99 (999 триллионов)

Пример:
выделяем 12887,03руб., результат (Двенадцать тысяч восемьсот восемьдесят семь) рублей 03 копейки

[vba]

Код

Sub ПРОПИСЬЮ()
'---------------------------------------------------------------------------------------
' Procedure    : ПРОПИСЬЮ
' Author       : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL    : http://www.excelworld.ru/forum/4-6947-1
' DateTime     : 29.10.2013, 17:19
' Purpose      : цифры из выделенного текста перевести в число прописью и вставить после выделения
' Notes        : Копейки вводить обязательно в двухзначном формате т.к. они берутся из расчета последние 2 числа
' Пример       : Строка "1201" либо "120,1" либо "12,01" преобразуется одинаково в "12 рублей 01 копейку"
'---------------------------------------------------------------------------------------
    If Selection.Type <> wdSelectionNormal Then Exit Sub
    Dim NNN, NNNOst, NNNLen
    With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = .Replace(Selection.Range.Text, ""): End With
    NNNLen = Len(NNN)
    If NNNLen > 17 Then Exit Sub
    NNNOst = Format(Right(NNN, 2), "00", 2)
    If NNNLen > 2 Then NNN = Left(NNN, NNNLen - 2) Else NNN = 0
    ' NNN = NNN & "," & NNNOst
    If Len(NNN) Then Selection.Start = Selection.End: Selection.Range.Text = " (" & СУМ_ПРОП(NNN, NNNOst)
End Sub
'-------------------------------------------------------------------------------------------------------------------------------------------  ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#, ByVal ЧИСЛОКОП#)  ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
    Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
    If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
    sot = Array("", " сто", " двести", " триста", " четыреста", " пятьсот", " шестьсот", " семьсот", " восемьсот", " девятьсот")
    des = Array("", "", " двадцать", " тридцать", " сорок", " пятьдесят", " шестьдесят", " семьдесят", " восемьдесят", " девяносто")
    nadc = Array(" десять", " одиннадцать", " двенадцать", " тринадцать", " четырнадцать", " пятнадцать", " шестнадцать", " семнадцать", " восемнадцать", " девятнадцать")
    ed = Array("", " один", " два", " три", " четыре", " пять", " шесть", " семь", " восемь", " девять", "", " одна", " две")
    RAZR = Array(" триллион", " триллиона", " триллионов", " миллиард", " миллиарда", " миллиардов", " миллион", " миллиона", " миллионов", " тысяча", " тысячи", " тысяч", ") рубль ", ") рубля ", ") рублей ")
    rub = Left(Format(ЧИСЛО, "000000000000000"), 15)
    kop = Left(Format(ЧИСЛОКОП, "00"), 2)
    If CDbl(rub) = 0 Then m = " ноль"
    For i = 1 To Len(rub) Step 3
        If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
            m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
                    des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
                    IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
        End If
    Next i
    m = LTrim(m)
    СУМ_ПРОП = UCase(Left(m, 1)) & Mid(m, 2) & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек", IIf(kop Mod 10 = 1, "йка", "йки"))
End Function

[/vba]

Автор - Naminator
Дата добавления - 17.01.2017 в 17:18

Дата: Вторник, 17.01.2017, 22:34 | Сообщение № 38

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3214

Репутация: 615 ±

Замечаний: 0% ±

2003

Цитата Naminator, 16.01.2017 в 12:44, в сообщении № 36 ()

' Author : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL : http://www.excelworld.ru/forum/4-6947-1
' DateTime : 29.10.2013, 17:19

Цитата Naminator, 17.01.2017 в 17:18, в сообщении № 38 ()

' Author : Alex_ST
' Topic_HEADER : Сумма прописью в Word - Как допилить? (Word)
' Topic_URL : http://www.excelworld.ru/forum/4-6947-1
' DateTime : 29.10.2013, 17:19

Naminator, ну Вы бы хоть заголовок процедуры правили. Я к Вашим доработкам никакого отношения не имею, адреса топиков не те, даты тоже.

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

карандаш

Дата: Понедельник, 13.02.2017, 08:00 | Сообщение № 39

Группа: Проверенные

Ранг: Обитатель

Сообщений: 329

Репутация: 8 ±

Замечаний: 0% ±

2010

есть такое решение

[vba]

Код

'------------------------------------------------------------------------------------------------------------------------------------------- ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#) ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
RAZR = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "", "", "")
rub = Left(Format(ЧИСЛО, "000000000000000.00"), 15)
kop = Right(Format(ЧИСЛО, "0.00"), 2)
If CDbl(rub) > 0 Then
For i = 1 To Len(rub) Step 3
If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
End If
Next i
СУМ_ПРОП = "(" & UCase(Left(m, 1)) & Mid(m, 2) & "рубл" & IIf(rub \ 10 = 1 Or ((rub + 9) Mod 10) >= 4, "ей", IIf(rub Mod 10 = 1, "ь", "я")) & _
"" 'kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)"))
Else: СУМ_ПРОП = "("
End If
End Function

Sub NumberToText()

Dim i, rr, n, nt, nz As Integer, ch, sFigs, sNum As String, FlagRub As Boolean
'
With Selection
' выделяем цифры и допустимые знаки разделения
.End = .Start
.MoveStartWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdBackward
.MoveEndWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdForward
' проверяем выделенное на валидность
If .End = .Start Then Exit Sub
sFigs = Replace(Replace(Replace(Replace(Replace(Replace(.Text, " ", ""), Chr(160), ""), Chr(39), ""), Chr(96), ""), Chr(145), ""), Chr(146), "")
n = Len(sFigs)
If n = 0 Then Exit Sub
nz = Len(sFigs) - Len(Replace(sFigs, ",", ""))
'nt = Len(sFigs) - Len(Replace(sFigs, ".", ""))
If nz > 1 Then i = MsgBox("Лишние запятые (больше одной)", 64): Exit Sub
'If nt > 1 Then i = MsgBox("Лишние точки (больше одной)", 64): Exit Sub
'If nz + nt > 1 Then i = MsgBox("Оставьте в качестве разделителя целой и дробной части либо точку, либо запятую", 64): Exit Sub
'If n - nz - nt < 1 Then Exit Sub
' убираем текст с цифрами
.Text = ""
' ищем слово "Руб*"
.MoveEndWhile "рублейяь. ", wdForward: FlagRub = False
sNum = Replace(Replace(Replace(Replace(Replace(.Text, "л", ""), "е", ""), "й", ""), ".", ""), " ", "")
If sNum = "руб" Then FlagRub = True
' убираем текст с "руб*", чтобы потом вставить "правильный" текст
.Text = ""
rr = Val(sFigs) ' преобразование из строки в целое число
n = sFigs ' преобразование из строки в число
frm = IIf(CDbl(n) = rr, "### ### ##0", "### ### ##0.00")
.Text = " " & Replace(Trim(Format(n, frm)), " ", Chr(160)): .Start = .End

If FlagRub Then .Text = " руб. ": .Start = .End

Dim NNN
With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = sFigs: End With
.Text = СУМ_ПРОП(NNN): .Start = .End
If Not FlagRub Then .Text = ")": Exit Sub
kop = Right(Format(n, "0.00"), 2): .Start = .End
If kop = "00" Then
.Text = ") ": Exit Sub
Else

.Text = IIf(rr, " ", "") & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)")) & " "
End If
End With

End Sub

[/vba]

надо указателем встать на число (текст, состоящий из цифр, разделённых пробелом, неразрвным пробелом, штрихом, запятой) и кликнуть по кнопке макроса в шапке ворда (кнопку поставить туда через настройку ленты)

есть такое решение

[vba]

Код

'------------------------------------------------------------------------------------------------------------------------------------------- ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#) ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
RAZR = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "", "", "")
rub = Left(Format(ЧИСЛО, "000000000000000.00"), 15)
kop = Right(Format(ЧИСЛО, "0.00"), 2)
If CDbl(rub) > 0 Then
For i = 1 To Len(rub) Step 3
If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
End If
Next i
СУМ_ПРОП = "(" & UCase(Left(m, 1)) & Mid(m, 2) & "рубл" & IIf(rub \ 10 = 1 Or ((rub + 9) Mod 10) >= 4, "ей", IIf(rub Mod 10 = 1, "ь", "я")) & _
"" 'kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)"))
Else: СУМ_ПРОП = "("
End If
End Function

Sub NumberToText()

Dim i, rr, n, nt, nz As Integer, ch, sFigs, sNum As String, FlagRub As Boolean
'
With Selection
' выделяем цифры и допустимые знаки разделения
.End = .Start
.MoveStartWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdBackward
.MoveEndWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdForward
' проверяем выделенное на валидность
If .End = .Start Then Exit Sub
sFigs = Replace(Replace(Replace(Replace(Replace(Replace(.Text, " ", ""), Chr(160), ""), Chr(39), ""), Chr(96), ""), Chr(145), ""), Chr(146), "")
n = Len(sFigs)
If n = 0 Then Exit Sub
nz = Len(sFigs) - Len(Replace(sFigs, ",", ""))
'nt = Len(sFigs) - Len(Replace(sFigs, ".", ""))
If nz > 1 Then i = MsgBox("Лишние запятые (больше одной)", 64): Exit Sub
'If nt > 1 Then i = MsgBox("Лишние точки (больше одной)", 64): Exit Sub
'If nz + nt > 1 Then i = MsgBox("Оставьте в качестве разделителя целой и дробной части либо точку, либо запятую", 64): Exit Sub
'If n - nz - nt < 1 Then Exit Sub
' убираем текст с цифрами
.Text = ""
' ищем слово "Руб*"
.MoveEndWhile "рублейяь. ", wdForward: FlagRub = False
sNum = Replace(Replace(Replace(Replace(Replace(.Text, "л", ""), "е", ""), "й", ""), ".", ""), " ", "")
If sNum = "руб" Then FlagRub = True
' убираем текст с "руб*", чтобы потом вставить "правильный" текст
.Text = ""
rr = Val(sFigs) ' преобразование из строки в целое число
n = sFigs ' преобразование из строки в число
frm = IIf(CDbl(n) = rr, "### ### ##0", "### ### ##0.00")
.Text = " " & Replace(Trim(Format(n, frm)), " ", Chr(160)): .Start = .End

If FlagRub Then .Text = " руб. ": .Start = .End

Dim NNN
With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = sFigs: End With
.Text = СУМ_ПРОП(NNN): .Start = .End
If Not FlagRub Then .Text = ")": Exit Sub
kop = Right(Format(n, "0.00"), 2): .Start = .End
If kop = "00" Then
.Text = ") ": Exit Sub
Else

.Text = IIf(rr, " ", "") & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)")) & " "
End If
End With

End Sub

[/vba]

надо указателем встать на число (текст, состоящий из цифр, разделённых пробелом, неразрвным пробелом, штрихом, запятой) и кликнуть по кнопке макроса в шапке ворда (кнопку поставить туда через настройку ленты)карандаш

Сообщение отредактировал карандаш - Понедельник, 13.02.2017, 08:04

Ответить

Сообщениеесть такое решение

[vba]

Код

'------------------------------------------------------------------------------------------------------------------------------------------- ------------
Function СУМ_ПРОП$(ByVal ЧИСЛО#) ' http://www.excelworld.ru/forum/3-9902-1 Author MCH (Михаил Ч.), май 2012
Dim rub$, kop$, ed, des, sot, nadc, RAZR, i&, m$
If ЧИСЛО >= 1E+15 Or ЧИСЛО < 0 Then Exit Function
sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
nadc = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ", "", "одна ", "две ")
RAZR = Array("триллион ", "триллиона ", "триллионов ", "миллиард ", "миллиарда ", "миллиардов ", "миллион ", "миллиона ", "миллионов ", "тысяча ", "тысячи ", "тысяч ", "", "", "")
rub = Left(Format(ЧИСЛО, "000000000000000.00"), 15)
kop = Right(Format(ЧИСЛО, "0.00"), 2)
If CDbl(rub) > 0 Then
For i = 1 To Len(rub) Step 3
If Mid(rub, i, 3) <> "000" Or i = Len(rub) - 2 Then
m = m & sot(CInt(Mid(rub, i, 1))) & IIf(Mid(rub, i + 1, 1) = "1", nadc(CInt(Mid(rub, i + 2, 1))), _
des(CInt(Mid(rub, i + 1, 1))) & ed(CInt(Mid(rub, i + 2, 1)) + IIf(i = Len(rub) - 5 And CInt(Mid(rub, i + 2, 1)) < 3, 10, 0))) & _
IIf(Mid(rub, i + 1, 1) = "1" Or (Mid(rub, i + 2, 1) + 9) Mod 10 >= 4, RAZR(i + 1), IIf(Mid(rub, i + 2, 1) = "1", RAZR(i - 1), RAZR(i)))
End If
Next i
СУМ_ПРОП = "(" & UCase(Left(m, 1)) & Mid(m, 2) & "рубл" & IIf(rub \ 10 = 1 Or ((rub + 9) Mod 10) >= 4, "ей", IIf(rub Mod 10 = 1, "ь", "я")) & _
"" 'kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)"))
Else: СУМ_ПРОП = "("
End If
End Function

Sub NumberToText()

Dim i, rr, n, nt, nz As Integer, ch, sFigs, sNum As String, FlagRub As Boolean
'
With Selection
' выделяем цифры и допустимые знаки разделения
.End = .Start
.MoveStartWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdBackward
.MoveEndWhile "0123456789, " & Chr(160) & Chr(39) & Chr(96) & Chr(145) & Chr(146), wdForward
' проверяем выделенное на валидность
If .End = .Start Then Exit Sub
sFigs = Replace(Replace(Replace(Replace(Replace(Replace(.Text, " ", ""), Chr(160), ""), Chr(39), ""), Chr(96), ""), Chr(145), ""), Chr(146), "")
n = Len(sFigs)
If n = 0 Then Exit Sub
nz = Len(sFigs) - Len(Replace(sFigs, ",", ""))
'nt = Len(sFigs) - Len(Replace(sFigs, ".", ""))
If nz > 1 Then i = MsgBox("Лишние запятые (больше одной)", 64): Exit Sub
'If nt > 1 Then i = MsgBox("Лишние точки (больше одной)", 64): Exit Sub
'If nz + nt > 1 Then i = MsgBox("Оставьте в качестве разделителя целой и дробной части либо точку, либо запятую", 64): Exit Sub
'If n - nz - nt < 1 Then Exit Sub
' убираем текст с цифрами
.Text = ""
' ищем слово "Руб*"
.MoveEndWhile "рублейяь. ", wdForward: FlagRub = False
sNum = Replace(Replace(Replace(Replace(Replace(.Text, "л", ""), "е", ""), "й", ""), ".", ""), " ", "")
If sNum = "руб" Then FlagRub = True
' убираем текст с "руб*", чтобы потом вставить "правильный" текст
.Text = ""
rr = Val(sFigs) ' преобразование из строки в целое число
n = sFigs ' преобразование из строки в число
frm = IIf(CDbl(n) = rr, "### ### ##0", "### ### ##0.00")
.Text = " " & Replace(Trim(Format(n, frm)), " ", Chr(160)): .Start = .End

If FlagRub Then .Text = " руб. ": .Start = .End

Dim NNN
With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = sFigs: End With
.Text = СУМ_ПРОП(NNN): .Start = .End
If Not FlagRub Then .Text = ")": Exit Sub
kop = Right(Format(n, "0.00"), 2): .Start = .End
If kop = "00" Then
.Text = ") ": Exit Sub
Else

.Text = IIf(rr, " ", "") & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)")) & " "
End If
End With

End Sub

[/vba]

надо указателем встать на число (текст, состоящий из цифр, разделённых пробелом, неразрвным пробелом, штрихом, запятой) и кликнуть по кнопке макроса в шапке ворда (кнопку поставить туда через настройку ленты)

Автор - карандаш
Дата добавления - 13.02.2017 в 08:00

Дата: Понедельник, 13.02.2017, 08:49 | Сообщение № 40

Группа: Пользователи

Ранг: Новичок

Сообщений: 24

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Карандаш!

Цитата карандаш, 13.02.2017 в 08:00, в сообщении № 39 ()

надо указателем встать на число

Здравствуйте! Макрос выводит прописью,но без копеек.

Ответить

Сумма прописью в Word - Как допилить? (Word)

Страница 2 из 3
«
1
2
3
»

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!