Здравствуйте Заранее прошу прощения за размещение здесь, но делаю это потому, как в прошлый раз произошла нестыковка по исполнителю и по выбранному разделу для размещения. (не знаю, в каком сейчас состоянии механизм/процедура выбора исполнителя)
Есть макрос (сделанный кем-то и "исправленный" мной, но не до конца), переводящий число в цифре в соответствующую надпись прописью. Необходимо довести до ума макрос. Суть - есть множество предметов, описываемых числом и единицей измерения (руб., шт., литры, тонны и пр.) - необходимы только рубли и штуки. Необходимо перевести написанное число в отформатированное число (с неразрывным пробелом между тысячами, а так же числом и единицей измерения) + правильная единица + пропись в скобках. Например, 2304,2 р. (или 2 304,2 руб., или 2304,2рублей) в 2_034,20_руб. (две тысячи тридцать четыре рубля и 20 копеек) (если копеек нет, то не должно быть запятой и 00 в числе, а так же "00 копеек". Или 2300шт. в 2_300_шт. (две тысячи триста штук), где "_" - неразрывный пробел
перенесите это сообщение, если я попал не туда
макрос [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 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) & " рубл" & 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, "йка)", "йки)")) End Function
[/vba]
[vba]
Код
Sub Макрос1()
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 = Int(sFigs) ' преобразование из строки в целое число n = sFigs ' преобразование из строки в число .Text = " " & Replace(Trim(Format(n, "### ### ### ### ##0")), " ", 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 .Text = kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)")) & " " End With
End Sub
[/vba] [moder]Код следует оформлять тегами (кнопка #), а не прятать под спойлер[/moder] спасибо
Здравствуйте Заранее прошу прощения за размещение здесь, но делаю это потому, как в прошлый раз произошла нестыковка по исполнителю и по выбранному разделу для размещения. (не знаю, в каком сейчас состоянии механизм/процедура выбора исполнителя)
Есть макрос (сделанный кем-то и "исправленный" мной, но не до конца), переводящий число в цифре в соответствующую надпись прописью. Необходимо довести до ума макрос. Суть - есть множество предметов, описываемых числом и единицей измерения (руб., шт., литры, тонны и пр.) - необходимы только рубли и штуки. Необходимо перевести написанное число в отформатированное число (с неразрывным пробелом между тысячами, а так же числом и единицей измерения) + правильная единица + пропись в скобках. Например, 2304,2 р. (или 2 304,2 руб., или 2304,2рублей) в 2_034,20_руб. (две тысячи тридцать четыре рубля и 20 копеек) (если копеек нет, то не должно быть запятой и 00 в числе, а так же "00 копеек". Или 2300шт. в 2_300_шт. (две тысячи триста штук), где "_" - неразрывный пробел
перенесите это сообщение, если я попал не туда
макрос [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 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) & " рубл" & 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, "йка)", "йки)")) End Function
[/vba]
[vba]
Код
Sub Макрос1()
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 = Int(sFigs) ' преобразование из строки в целое число n = sFigs ' преобразование из строки в число .Text = " " & Replace(Trim(Format(n, "### ### ### ### ##0")), " ", 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 .Text = kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек)", IIf(kop Mod 10 = 1, "йка)", "йки)")) & " " End With
End Sub
[/vba] [moder]Код следует оформлять тегами (кнопка #), а не прятать под спойлер[/moder] спасибокарандаш
Сообщение отредактировал Pelena - Четверг, 27.08.2015, 18:59
Michael_S, в разумных пределах и за качественную работу желательно в том же стиле (методах обработки), которые применены в уже существующем макросе [moder]Переношу тему в раздел Работа/Фриланс.[/moder]
Michael_S, в разумных пределах и за качественную работу желательно в том же стиле (методах обработки), которые применены в уже существующем макросе [moder]Переношу тему в раздел Работа/Фриланс.[/moder]карандаш
Сообщение отредактировал Manyasha - Четверг, 27.08.2015, 17:33
озвучте свои пределы. Если стимул будет "стимулирующим", мне будет полезно потренироваться. Ну, или кто-нибудь возьмется. И с вас файл-пример с различными исходными данными и что нужно на выходе.
озвучте свои пределы. Если стимул будет "стимулирующим", мне будет полезно потренироваться. Ну, или кто-нибудь возьмется. И с вас файл-пример с различными исходными данными и что нужно на выходе.Michael_S
Никакой нестыковки не было. Вы разместили заказ на сайте, и создали дублирующую тему на форуме. Ответ был дан nilem в дублирующей теме. Но заглянуть туда вы соизволили только после моего ответа. Насколько помню, это когда то был макрос AndreTM.
Никакой нестыковки не было. Вы разместили заказ на сайте, и создали дублирующую тему на форуме. Ответ был дан nilem в дублирующей теме. Но заглянуть туда вы соизволили только после моего ответа. Насколько помню, это когда то был макрос AndreTM.RAN
можно узнать сложность доделки в рублях? плюс-минус примерно
в комментариях написано, да. Просто у меня было три подобных макроса , взятых с этого сайта с разных страниц. Этот почему-то больше приглянулся (наверное, потому, что быстрее поддался на переделки)
p.s. простите, не могу найти ссылку, по клику по которой можно почитать личные сообщения (если они есть)
можно узнать сложность доделки в рублях? плюс-минус примерно
в комментариях написано, да. Просто у меня было три подобных макроса , взятых с этого сайта с разных страниц. Этот почему-то больше приглянулся (наверное, потому, что быстрее поддался на переделки)
p.s. простите, не могу найти ссылку, по клику по которой можно почитать личные сообщения (если они есть)карандаш
Сообщение отредактировал карандаш - Понедельник, 31.08.2015, 14:22
Попробую пока взяться посмотреть, что получится... но там, как я понял, надо думать не над исправлением функции (чего там править-то особо?) а над процессом её использования в Word, особенно, когда надо поправить уже "расшифрованное" число
Попробую пока взяться посмотреть, что получится... но там, как я понял, надо думать не над исправлением функции (чего там править-то особо?) а над процессом её использования в Word, особенно, когда надо поправить уже "расшифрованное" число AndreTM
макрос нужно именно поправить, т.к. как он работает я в принципе понимаю, а пользоваться другим - это значит надо разбираться в его работе, а в VB у меня не очень получается. Пользоваться тем, в чем не разбираешься - сложно.
поэтому именно поправить - там пробелы не всегда правильно ставятся и копейки неправильно пишутся (нулевые не надо писать, а если копейки есть, то они не пишутся цифрой (которая к тому же округляется до рублей)
не знаю, насколько это муторно, но между 0,5 и 1 т.р. на вскидку. Если задача стоит дороже... то... Хотя, опять же инфляция... доллар... нефть... катаклизьмы разные. Трудно оценивать труд, которые не можешь оценить.
штуки добавить по аналогии - только если это совсем не трудно. Если нужно повозиться, то не надо - проще ручками поправить, чем тратить время и деньги)
макрос нужно именно поправить, т.к. как он работает я в принципе понимаю, а пользоваться другим - это значит надо разбираться в его работе, а в VB у меня не очень получается. Пользоваться тем, в чем не разбираешься - сложно.
поэтому именно поправить - там пробелы не всегда правильно ставятся и копейки неправильно пишутся (нулевые не надо писать, а если копейки есть, то они не пишутся цифрой (которая к тому же округляется до рублей)
не знаю, насколько это муторно, но между 0,5 и 1 т.р. на вскидку. Если задача стоит дороже... то... Хотя, опять же инфляция... доллар... нефть... катаклизьмы разные. Трудно оценивать труд, которые не можешь оценить.
штуки добавить по аналогии - только если это совсем не трудно. Если нужно повозиться, то не надо - проще ручками поправить, чем тратить время и деньги)карандаш
карандаш, ну,я-то работаю... вернее, тогда в начале недели покопался - и отложил до выходных, это ж Ворд, я с ним работаю раз в полгода , приходится каждый раз перечитывать кучу ссылок в справке по объектной модели...
карандаш, ну,я-то работаю... вернее, тогда в начале недели покопался - и отложил до выходных, это ж Ворд, я с ним работаю раз в полгода , приходится каждый раз перечитывать кучу ссылок в справке по объектной модели...AndreTM
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
