Народ, тут понадобилось договора писать, а там сумма прописью... Можно было бы, конечно, и имеющимися наработками для Excel'я воспользоваться, но я у себя в копилке нашёл, что числа до 999999 можно в текст прямо Вордом перегонять (например, здесь, здесь, здесь, ...). Решил попробовать. Вот что примерно получилось:[vba]
Код
Sub SumPropWord() With Selection '.Range.Text = Replace(.Range.Text, " ", "") .Fields.Add .Range, Type:=wdFieldEmpty, Text:="=" & .Range.Text & " \*CardText", PreserveFormatting:=False .Fields.Update End With End Sub
[/vba] И всё бы, наверное, и ничего, да вот только триады цифр в документе для читабельности обычно разбиваются пробелом. А с пробелами не пашет. Попытался тупо заменить пробел на "пустышку" Replace'ом в Selection.Range.Text - не вышло - макрос стал давать ошибку в формуле... Я объектную модель Ворда практически не знаю. Тыкаю почти наугад по аналогии с Excel'ем Конечно, идеалом было бы допилить макрос так, чтобы он ПОСЛЕ (а не ВМЕСТО) выделенного числа выдавал его же прописью, но это уже не так важно.
Народ, тут понадобилось договора писать, а там сумма прописью... Можно было бы, конечно, и имеющимися наработками для Excel'я воспользоваться, но я у себя в копилке нашёл, что числа до 999999 можно в текст прямо Вордом перегонять (например, здесь, здесь, здесь, ...). Решил попробовать. Вот что примерно получилось:[vba]
Код
Sub SumPropWord() With Selection '.Range.Text = Replace(.Range.Text, " ", "") .Fields.Add .Range, Type:=wdFieldEmpty, Text:="=" & .Range.Text & " \*CardText", PreserveFormatting:=False .Fields.Update End With End Sub
[/vba] И всё бы, наверное, и ничего, да вот только триады цифр в документе для читабельности обычно разбиваются пробелом. А с пробелами не пашет. Попытался тупо заменить пробел на "пустышку" Replace'ом в Selection.Range.Text - не вышло - макрос стал давать ошибку в формуле... Я объектную модель Ворда практически не знаю. Тыкаю почти наугад по аналогии с Excel'ем Конечно, идеалом было бы допилить макрос так, чтобы он ПОСЛЕ (а не ВМЕСТО) выделенного числа выдавал его же прописью, но это уже не так важно.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Понедельник, 28.10.2013, 16:33
Poltava, спасибо за совет и попытку помочь. А со вставкой после подождём, может быть кто-нибудь из более продвинутых в Ворде чем мы откликнется. А то, глядишь, и сумму прописью от МСН прикрутим чтобы снять ограничения
Poltava, спасибо за совет и попытку помочь. А со вставкой после подождём, может быть кто-нибудь из более продвинутых в Ворде чем мы откликнется. А то, глядишь, и сумму прописью от МСН прикрутим чтобы снять ограниченияAlex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Вторник, 29.10.2013, 14:40
Sub SumPropWord() Dim aa# With Selection aa = CDbl(Replace(Replace(.Range.Text, Chr(160), ""), " ", "")) .Range.Text = .Range.Text & " " & MSumProp(aa) End With End Sub Function MSumProp$(chislo#) 'Автор MCH (Михаил Ч.), май 2012 Dim rub$, kop$, ed, des, sot, nadc, razr, i&, m$ If chislo >= 1E+15 Or chislo < 0 Then Exit Function
rub = Left(Format(chislo, "000000000000000.00"), 15) kop = Right(Format(chislo, "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 MSumProp = 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]
Леш, может я что не так понял? [vba]
Код
Sub SumPropWord() Dim aa# With Selection aa = CDbl(Replace(Replace(.Range.Text, Chr(160), ""), " ", "")) .Range.Text = .Range.Text & " " & MSumProp(aa) End With End Sub Function MSumProp$(chislo#) 'Автор MCH (Михаил Ч.), май 2012 Dim rub$, kop$, ed, des, sot, nadc, razr, i&, m$ If chislo >= 1E+15 Or chislo < 0 Then Exit Function
rub = Left(Format(chislo, "000000000000000.00"), 15) kop = Right(Format(chislo, "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 MSumProp = 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
Видимо хочется средствами Word осуществить перевод числа в сумму прописью. [vba]
Код
Public Sub test3() Dim pReg As Object Dim numField As Field Dim numText As String
If Selection.Characters.Count > 1 Then Set pReg = CreateObject("VBScript.RegExp") pReg.Global = True: pReg.Pattern = "[^\d]+" numText = pReg.Replace(Selection.Text, "") If Len(numText) > 0 Then Selection.MoveRight Count:=1 Selection.TypeText " " Set numField = Selection.Fields.Add(Selection.Range, wdFieldEmpty, "=" & numText & "\*CardText", False) numField.Update End If End If End Sub
[/vba]
Видимо хочется средствами Word осуществить перевод числа в сумму прописью. [vba]
Код
Public Sub test3() Dim pReg As Object Dim numField As Field Dim numText As String
If Selection.Characters.Count > 1 Then Set pReg = CreateObject("VBScript.RegExp") pReg.Global = True: pReg.Pattern = "[^\d]+" numText = pReg.Replace(Selection.Text, "") If Len(numText) > 0 Then Selection.MoveRight Count:=1 Selection.TypeText " " Set numField = Selection.Fields.Add(Selection.Range, wdFieldEmpty, "=" & numText & "\*CardText", False) numField.Update End If End If End Sub
Народ, спасибо за отзывы. К сожалению, уже опять меня настиг завал на работе и разбираться совершенно некогда. А внутренние средства Ворда я для того применил, т.к. была задумка чтобы сумма прописью вводилась макросом как поле, вычисляемое по сумме цифрами, которую можно было бы потом спокойно изменять в ручную (ну как у нас, нормальных в Excel'e формула, использующая UDF).
Хотя всё-таки не удержался и проверил вариант от RAN Андрей! Спасибо большое. Отлично работает!
Народ, спасибо за отзывы. К сожалению, уже опять меня настиг завал на работе и разбираться совершенно некогда. А внутренние средства Ворда я для того применил, т.к. была задумка чтобы сумма прописью вводилась макросом как поле, вычисляемое по сумме цифрами, которую можно было бы потом спокойно изменять в ручную (ну как у нас, нормальных в Excel'e формула, использующая UDF).
Хотя всё-таки не удержался и проверил вариант от RAN Андрей! Спасибо большое. Отлично работает!Alex_ST
[/vba]даёт инвалид-аргумент при выделенном 123456 на листе [offtop]А объектную модель-то Ворда, оказывается кто-то всё-таки знает... Столько абсолютно ничего не говорящих мне свойств, методов и параметров в коде![/offtop]
[/vba]даёт инвалид-аргумент при выделенном 123456 на листе [offtop]А объектную модель-то Ворда, оказывается кто-то всё-таки знает... Столько абсолютно ничего не говорящих мне свойств, методов и параметров в коде![/offtop]Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Вторник, 29.10.2013, 13:36
Выдалась минутка поковыряться с вариантом, предложенным RAN Решил, что число прописью лучше вставлять в буфер обмена, а уж пользователь сам потом будет решать, рубли там или юани и куда их вставлять. Вот что получилось:
[vba]
Код
Sub Прописью() Dim NNN On Error Resume Next With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = CDbl(.Replace(Selection.Range.Text, "")): End With NNN = IIf(Err, Err.Description, СУМ_ПРОП(NNN)) With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .SetText NNN: .PutInClipBoard: End With End Sub Function СУМ_ПРОП$(ByVal ЧИСЛО#) ' http://www.excelworld.ru/forum/3-3521-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]
Выдалась минутка поковыряться с вариантом, предложенным RAN Решил, что число прописью лучше вставлять в буфер обмена, а уж пользователь сам потом будет решать, рубли там или юани и куда их вставлять. Вот что получилось:
[vba]
Код
Sub Прописью() Dim NNN On Error Resume Next With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\D": NNN = CDbl(.Replace(Selection.Range.Text, "")): End With NNN = IIf(Err, Err.Description, СУМ_ПРОП(NNN)) With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): .SetText NNN: .PutInClipBoard: End With End Sub Function СУМ_ПРОП$(ByVal ЧИСЛО#) ' http://www.excelworld.ru/forum/3-3521-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]
Код
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) & ") " End Sub
[/vba]
Хотя, с буфером обмена - это, пожалуй, лишнее. Лучше будет в скобочках после выделения выводить так: [vba]
Код
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) & ") " End Sub
А если не выделять ничего? Просто курсор поставить "посреди" числа? Я больше ориентировался на то, чтобы не заставлять пользователя выделять число (и ещё обычно при ручном выделении дефолтный Expand срабатывает, расширяя область выделения по своему разумению).
По ошибке - это Word VBA, гад, всё равно считает в Left(,-1) в IIF() ... можно сделать [vba]
Код
nValue2 = 0 If nShift > 1 Then nValue2 = Val(Right(.Text, nShift - 1))
[/vba]
Что касается "сумма вводилась как поле" - она и так вводится в поле. Поэтому, кстати, исходный вариант и предполагал замену текста полем, чтобы число оставалось единственным. А чтобы можно было "менять сумму", не заходя в поле - надо либо текст преобразовать в поле с меткой (закладкой), на которую потом будет ссылаться сумма прописью, либо отслеживать изменение текста и перезаписывать/пересоздавать поле с прописью. Ещё хочу заметить - .MoveRight Unit:=wdWord сдвинет точку ввода хоть и на конец цифр - но там может стоять разделитель Например, сумма записана (как это любят бухи) "123456=00" - тогда что? Да и число может быть "Ноль" (например, остаток суммы оплаты)...
А если не выделять ничего? Просто курсор поставить "посреди" числа? Я больше ориентировался на то, чтобы не заставлять пользователя выделять число (и ещё обычно при ручном выделении дефолтный Expand срабатывает, расширяя область выделения по своему разумению).
По ошибке - это Word VBA, гад, всё равно считает в Left(,-1) в IIF() ... можно сделать [vba]
Код
nValue2 = 0 If nShift > 1 Then nValue2 = Val(Right(.Text, nShift - 1))
[/vba]
Что касается "сумма вводилась как поле" - она и так вводится в поле. Поэтому, кстати, исходный вариант и предполагал замену текста полем, чтобы число оставалось единственным. А чтобы можно было "менять сумму", не заходя в поле - надо либо текст преобразовать в поле с меткой (закладкой), на которую потом будет ссылаться сумма прописью, либо отслеживать изменение текста и перезаписывать/пересоздавать поле с прописью. Ещё хочу заметить - .MoveRight Unit:=wdWord сдвинет точку ввода хоть и на конец цифр - но там может стоять разделитель Например, сумма записана (как это любят бухи) "123456=00" - тогда что? Да и число может быть "Ноль" (например, остаток суммы оплаты)...AndreTM
Skype: andre.tm.007 Donate: Qiwi: 9517375010
Сообщение отредактировал AndreTM - Вторник, 29.10.2013, 22:24
А если не выделять ничего? Просто курсор поставить "посреди" числа? Я больше ориентировался на то, чтобы не заставлять пользователя выделять число
Андрей, как раз этот вариант скорее всего не прокатит, т.к. бухгалтеры чаще всего цифры разделяют пробелами на триады. Тогда в Вашем варианте при курсоре, стоящем между двоек в числе, например, 111 222 333, в пропись будет преобразовано только 222. Так что как раз пользователь и должен напрячь чуть-чуть извилины и выделить именно всё то, что он хочет преобразовать. В моём крайнем примере регулярка как раз это и делает - из выделенного фрагмента удаляет все символы кроме цифр.
А если не выделять ничего? Просто курсор поставить "посреди" числа? Я больше ориентировался на то, чтобы не заставлять пользователя выделять число
Андрей, как раз этот вариант скорее всего не прокатит, т.к. бухгалтеры чаще всего цифры разделяют пробелами на триады. Тогда в Вашем варианте при курсоре, стоящем между двоек в числе, например, 111 222 333, в пропись будет преобразовано только 222. Так что как раз пользователь и должен напрячь чуть-чуть извилины и выделить именно всё то, что он хочет преобразовать. В моём крайнем примере регулярка как раз это и делает - из выделенного фрагмента удаляет все символы кроме цифр.
Не пробовал, т.к. выяснилось, что 999 999 всё равно мало. А должно было получиться? Ну ты бы хоть полный текст процедуры выложил тогда, а не фрагмент чтобы его можно было просто не заморачиваясь началом и концом процедуры проверить.
??? Это что, у вас в бюстгалтерии так принято: вместо запятой в качестве разделителя рублей и копеек = использовать? Уж сколько разных договоров из разных мест видел, а такого - нет!
Не пробовал, т.к. выяснилось, что 999 999 всё равно мало. А должно было получиться? Ну ты бы хоть полный текст процедуры выложил тогда, а не фрагмент чтобы его можно было просто не заморачиваясь началом и концом процедуры проверить.
??? Это что, у вас в бюстгалтерии так принято: вместо запятой в качестве разделителя рублей и копеек = использовать? Уж сколько разных договоров из разных мест видел, а такого - нет!Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Среда, 30.10.2013, 19:23
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
в Excel'e формула, использующая UDF). 
То есть? Вот передо мною лежит договор аренды: 
