О, ты не представляешь, сколько ещё олдскул-спецов попадается. И я их не виню - есть регламенты оформления, которые иногда просто не меняются. Да и вообще, например, ты платежные поручения видел? Через какой разделитель там копейки? Кроме того, запись суммы "по-русски", через запятую - приводит к ошибкам при преобразовании через Val()/CDbl() - ибо для VBA стандартным разделителем является точка.
О, ты не представляешь, сколько ещё олдскул-спецов попадается. И я их не виню - есть регламенты оформления, которые иногда просто не меняются. Да и вообще, например, ты платежные поручения видел? Через какой разделитель там копейки? Кроме того, запись суммы "по-русски", через запятую - приводит к ошибкам при преобразовании через Val()/CDbl() - ибо для VBA стандартным разделителем является точка.AndreTM
Дата: Понедельник, 20.01.2014, 23:09 |
Сообщение № 22
Группа: Гости
Самая грамотная тема в интернете по данному вопросу! Уважаемые камрады, помогите в решении следующего вопроса. У меня много договоров. Как правило суммы в миллионах, иногда в миллиардах, без копеек. Я хотел бы, чтобы, когда я меняю сумму договора, чтобы сумма прописью в скобочках возле числа автоматически переписывалась. Например. Беру я за болванку старый договор, там старая сумма и пропись соответственно тоже, я вписываю новую сумму, в пропись автоматом переписывается, как в excele. Я прошу расписать все как для дебила, потому что я не программист, и мне тяжко сразу врубиться в ньюансы. Хотя макрос AndreTM я запустил и все заработало.
Самая грамотная тема в интернете по данному вопросу! Уважаемые камрады, помогите в решении следующего вопроса. У меня много договоров. Как правило суммы в миллионах, иногда в миллиардах, без копеек. Я хотел бы, чтобы, когда я меняю сумму договора, чтобы сумма прописью в скобочках возле числа автоматически переписывалась. Например. Беру я за болванку старый договор, там старая сумма и пропись соответственно тоже, я вписываю новую сумму, в пропись автоматом переписывается, как в excele. Я прошу расписать все как для дебила, потому что я не программист, и мне тяжко сразу врубиться в ньюансы. Хотя макрос AndreTM я запустил и все заработало.Алексей
Я сначала с Вашим пытался. у меня не получилось. Я видимо, что-то перепутал, так как не разобрался, как из двух Ваших постов сделать один макрос. А макрос AndreTM успешно сделал мне 16550200. Жаль, что нельзя сделать автоматическое пересчитывание.
Я сначала с Вашим пытался. у меня не получилось. Я видимо, что-то перепутал, так как не разобрался, как из двух Ваших постов сделать один макрос. А макрос AndreTM успешно сделал мне 16550200. Жаль, что нельзя сделать автоматическое пересчитывание.Алексей
Специально для 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
Уважаемый Alex_ST! Макрос, предложенный Вами, сумму в рублях 8309931,01 выдает в виде "(Восемьсот тридцать миллионов девятьсот девяносто три тысячи двести один )". Помогите разобраться с ошибкой!
Уважаемый Alex_ST! Макрос, предложенный Вами, сумму в рублях 8309931,01 выдает в виде "(Восемьсот тридцать миллионов девятьсот девяносто три тысячи двести один )". Помогите разобраться с ошибкой!Рaмиля
Сообщение отредактировал рамиля - Понедельник, 28.12.2015, 11:50
Спасибо krosav4ig! Замену в коде сделала! Целая часть считывается правильно. Но, что нужно поменять в коде для считывания в виде "Восемь миллионов триста девять тысяч девятьсот тридцать два рубля 01 копейка"?
Спасибо krosav4ig! Замену в коде сделала! Целая часть считывается правильно. Но, что нужно поменять в коде для считывания в виде "Восемь миллионов триста девять тысяч девятьсот тридцать два рубля 01 копейка"?Рaмиля
Сообщение отредактировал рамиля - Вторник, 29.12.2015, 08:32
Друзья, подскажите, можно ли внести изменения в макрос так, чтобы в конце не было пробела перед скобкой? Например 1'000: получается (Одна тысяча ), хотелось бы (Одна тысяча) Заранее спасибо)
использую из сообщения 25
Друзья, подскажите, можно ли внести изменения в макрос так, чтобы в конце не было пробела перед скобкой? Например 1'000: получается (Одна тысяча ), хотелось бы (Одна тысяча) Заранее спасибо)
Исправил под свою задачу. Сумму необходимо вводить с копейками, копейки указывать в двухзначном формате! Строка "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
'------------------------------------------------------------------------------------------------------------------------------------------- ------------ 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