Страницы: 1
RSS
Сумма прописью WORD, Помогите допилить макрос WORD
 
Добрый день, макрос в normal.dot пишет сумму 100000,00 видом (сто тысяч) рублей 00 копеек
Помогите реализовать запись с дубрилованием суммы с разделением пробелом разрядов

Образец:
Сумма: 100000,00 Пропись: 100 000 (сто тысяч) рублей 00 копеек

Код
Sub Прописью()
    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 ЧИСЛОКОП#)
    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)
    СУМ_ПРОП = RTrim(Left(m, 1)) & Mid(m, 2) & kop & " копе" & IIf(kop \ 10 = 1 Or ((kop + 9) Mod 10) >= 4, "ек", IIf(kop Mod 10 = 1, "йка", "йки"))
End Function
 
Закрыто

Автор попросил не делиться решением.
Изменено: Максим - 04.06.2020 16:52:38
 
Поделитесь решением с другими.
 
Цитата
Максим написал:
Сумма: 100000,00 Пропись: 100 000 (сто тысяч) рублей 00 копеек
чиорт, я думал это ветка работа и гонорар.  :D
По вопросам из тем форума, личку не читаю.
 
Цитата
Максим написал:
Автор попросил не делиться решением.
Автор совершенно прав, функция F....t доступна лишь избранным.

Цитата
Совершенно секретно. Перед прочтением сжечь.
Владимир
 
Цитата
Максим написал: Автор попросил не делиться решением.
Это отношение потребителя
Вы зашли на форум за помощью, создали тему. Помощь получили - а другим помочь не хотите? Тема мусором пусть висит?
Страницы: 1
Наверх