Сумма чисел прописью

Public Function funSupr(xsu As Variant, Optional mb As Byte) As String
On Error GoTo ersupr
If Not IsNumeric(xsu) Then
funSupr = ""
Exit Function
End If
If xsu >= 10000000000000# Then
funSupr = "слишком большое число"
Exit Function
End If
Dim ssu As String, nsu, edi, des, sot, ind As Byte, i As Integer
If Fix(xsu) = 0 Then
funSupr = "ноль рублей "
Else
ssu = Mid$(str$(Fix(xsu)), 2) ' строка рублей без знака
nsu = (Len(ssu) + 2) \ 3 ' количество троек цифр
ssu = Right$("00", nsu * 3 - Len(ssu)) + ssu ' добавляем нулями
For i = nsu To 1 Step -1
sot = Val(Mid$(ssu, (nsu - i) * 3 + 1, 1)) ' сотни
des = Val(Mid$(ssu, (nsu - i) * 3 + 2, 1)) ' десятки
edi = Val(Mid$(ssu, (nsu - i) * 3 + 3, 1)) ' единицы
If sot + des + edi > 0 Or i = 1 Then
If sot > 0 Then
funSupr = funSupr + Choose(sot, "сто", "двести", "триста", _
"четыреста", "пятьсот", "шестьсот", "семьсот", "восемьсот", _
"девятьсот") + " "
End If
If des = 1 Then
funSupr = funSupr + Choose(edi + 1, "десять", "одиннадцать", _
"двенадцать", "тринадцать", "четырнадцать", "пятнадцать", "шестнадцать", _
"семнадцать", "восемнадцать", "девятнадцать") + " "
ind = 3
Else
If des <> 0 Then
funSupr = funSupr + Choose(des - 1, "двадцать", _
"тридцать", "сорок", "пятьдесят", "шестьдесят", "семьдесят", "восемьдесят", _
"девяносто") + " "
End If
If edi <> 0 Then ' вычисляем индекс для тысяч (одна,две)
If i = 2 And (edi = 1 Or edi = 2) Then
ind = 9
Else
ind = 0
End If
funSupr = funSupr + Choose(edi + ind, "один", "два", _
"три", "четыре", "пять", "шесть", "семь", "восемь", "девять", "одна", _
"две") + " "
End If
Select Case edi
Case 1
ind = 1
Case 2, 3, 4
ind = 2
Case Else
ind = 3
End Select
End If
funSupr = funSupr + Choose((i - 1) * 3 + ind, "рубль", "рубля", "рублей", _
"тысяча", "тысячи", "тысяч", "миллион", "миллиона", "миллионов", _
"миллиард", "миллиарда", "миллиардов", "триллион", "триллиона", _
"триллионов") + " "
End If
Next i
End If
ssu = Right$(Format$(xsu, "0.00"), 2)
des = Val(Left$(ssu, 1))
edi = Val(Right$(ssu, 1))
If des = 1 Then
ind = 3
Else
Select Case edi
Case 1
ind = 1
Case 2, 3, 4
ind = 2
Case Else
ind = 3
End Select
End If
funSupr = funSupr + ssu + Choose(ind, " копейка", " копейки", " копеек")
If mb = 0 Then
funSupr = UCase$(Left$(funSupr, 1)) + Mid$(funSupr, 2)
End If
Exit Function
ersupr:
funSupr = "ошибка"
End Function
 
 
Sub ЧислоПрописью2()
Dim Summa$
Summa$ = funSupr(Selection.Text, 1)
If Summa$ <> "" Then ' допустимое значение
Selection.Text = Selection.Text + " (" + Summa$ + ") "
End If
End Sub

Function РубПропись(Сумма As Double, Optional Без_копеек As Boolean = False, _
 Optional КопПрописью As Boolean = False, Optional начинитьПрописной As Boolean = True) As String
'Функция для написания суммы прописью
 Dim ed, des, sot, ten, razr, dec
 Dim i As Integer, str As String, s As String
 Dim intPart As String, frPart As String
 Dim mlnEnd, tscEnd, razrEnd, rub, cop
 dec = Array("", "одна ", "две ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ten = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
 des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
 sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
 razr = Array("", "тысяч", "миллион", "миллиард")
 mlnEnd = Array("ов ", " ", "а ", "а ", "а ", "ов ", "ов ", "ов ", "ов ", "ов ")
 tscEnd = Array(" ", "а ", "и ", "и ", "и ", " ", " ", " ", " ", " ")
 razrEnd = Array(mlnEnd, mlnEnd, tscEnd, "")
 rub = Array("рублей", "рубль", "рубля", "рубля", "рубля", "рублей", "рублей", "рублей", "рублей", "рублей")
 cop = Array("копеек", "копейка", "копейки", "копейки", "копейки", "копеек", "копеек", "копеек", "копеек", "копеек")
 If Сумма >= 1000000000000# Or Сумма < 0 Then РубПропись = CVErr(xlErrValue): Exit Function
 '&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
 If Round(Сумма, 2) >= 1 Then
 intPart = Left$(Format(Сумма, "000000000000.00"), 12)
 For i = 0 To 3
 s = Mid$(intPart, i * 3 + 1, 3)
 If s <> "000" Then
 str = str & sot(CInt(Left$(s, 1)))
 If Mid$(s, 2, 1) = "1" Then
 str = str & ten(CInt(Right$(s, 1)))
 Else
 str = str & des(CInt(Mid$(s, 2, 1))) & IIf(i = 2, dec(CInt(Right$(s, 1))), ed(CInt(Right$(s, 1))))
 End If
 On Error Resume Next
 str = str & IIf(Mid$(s, 2, 1) = "1", razr(3 - i) & razrEnd(i)(0), _
 razr(3 - i) & razrEnd(i)(CInt(Right$(s, 1))))
 On Error GoTo 0
 End If
 Next i
 str = str & IIf(Mid$(s, 2, 1) = "1", rub(0), rub(CInt(Right$(s, 1))))
 End If
 РубПропись = str
 ''''''''''''''''''
 If Без_копеек = False Then
 frPart = Right$(Format(Сумма, "0.00"), 2)
 If frPart = "00" Then
 frPart = ""
 Else
 If КопПрописью Then
 frPart = IIf(Left$(frPart, 1) = "1", ten(CInt(Right$(frPart, 1))) & cop(0), _
 des(CInt(Left$(frPart, 1))) & dec(CInt(Right$(frPart, 1))) & cop(CInt(Right$(frPart, 1))))
 Else
 frPart = IIf(Left$(frPart, 1) = "1", frPart & " " & cop(0), frPart & " " & cop(CInt(Right$(frPart, 1))))
 End If
 End If
 РубПропись = str & " " & frPart
 End If
 ''''''''''''''''''
' РубПропись = str & frPart
 If начинитьПрописной Then Mid$(РубПропись, 1, 1) = UCase(Mid$(РубПропись, 1, 1))
' If начинитьПрописной Then РубПропись = UCase(Left(РубПропись, 1)) & Mid(РубПропись, 2)
End Function

Function РубПропись(Сумма As Double, Optional Без_копеек As Boolean = False, _
 Optional КопПрописью As Boolean = False, Optional начинитьПрописной As Boolean = True) As String
'Функция для написания суммы прописью
 Dim ed, des, sot, ten, razr, dec
 Dim i As Integer, str As String, s As String
 Dim intPart As String, frPart As String
 Dim mlnEnd, tscEnd, razrEnd, rub, cop
 dec = Array("ноль ", "одна ", "две ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ten = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
 des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
 sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
 razr = Array("", "тысяч", "миллион", "миллиард")
 mlnEnd = Array("ов ", " ", "а ", "а ", "а ", "ов ", "ов ", "ов ", "ов ", "ов ")
 tscEnd = Array(" ", "а ", "и ", "и ", "и ", " ", " ", " ", " ", " ")
 razrEnd = Array(mlnEnd, mlnEnd, tscEnd, "")
 rub = Array("рублей", "рубль", "рубля", "рубля", "рубля", "рублей", "рублей", "рублей", "рублей", "рублей")
 cop = Array("копеек", "копейка", "копейки", "копейки", "копейки", "копеек", "копеек", "копеек", "копеек", "копеек")
 If Сумма >= 1000000000000# Or Сумма < 0 Then РубПропись = CVErr(xlErrValue): Exit Function
 '&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
 If Round(Сумма, 2) >= 1 Then
 intPart = Left$(Format(Сумма, "000000000000.00"), 12)
 For i = 0 To 3
 s = Mid$(intPart, i * 3 + 1, 3)
 If s <> "000" Then
 str = str & sot(CInt(Left$(s, 1)))
 If Mid$(s, 2, 1) = "1" Then
 str = str & ten(CInt(Right$(s, 1)))
 Else
 str = str & des(CInt(Mid$(s, 2, 1))) & IIf(i = 2, dec(CInt(Right$(s, 1))), ed(CInt(Right$(s, 1))))
 End If
 On Error Resume Next
 str = str & IIf(Mid$(s, 2, 1) = "1", razr(3 - i) & razrEnd(i)(0), _
 razr(3 - i) & razrEnd(i)(CInt(Right$(s, 1))))
 On Error GoTo 0
 End If
 Next i
 str = str & IIf(Mid$(s, 2, 1) = "1", rub(0), rub(CInt(Right$(s, 1))))
 End If
 РубПропись = str
 ''''''''''''''''''
 If Без_копеек = False Then
 frPart = Right$(Format(Сумма, "0.00"), 2)
 If frPart = "ноль " Then
 frPart = "ноль "
 Else
 If КопПрописью Then
 frPart = IIf(Left$(frPart, 1) = "1", ten(CInt(Right$(frPart, 1))) & cop(0), _
 des(CInt(Left$(frPart, 1))) & dec(CInt(Right$(frPart, 1))) & cop(CInt(Right$(frPart, 1))))
 Else
 frPart = IIf(Left$(frPart, 1) = "1", frPart & " " & cop(0), frPart & " " & cop(CInt(Right$(frPart, 1))))
 End If
 End If
 РубПропись = str & " " & frPart
 End If
 ''''''''''''''''''
' РубПропись = str & frPart
 If начинитьПрописной Then Mid$(РубПропись, 1, 1) = UCase(Mid$(РубПропись, 1, 1))
' If начинитьПрописной Then РубПропись = UCase(Left(РубПропись, 1)) & Mid(РубПропись, 2)
End Function

Sub ЧислоПрописью2()
Dim Summa$
Summa$ = funSupr(Selection.Text, 1)
If Summa$ <> "" Then ' допустимое значение
Selection.Text = Selection.Text + " (" + Summa$ + ") "
End If
End Sub

Function РубПропись(Сумма As Double) As String
'Функция для написания суммы прописью
 Dim ed, des, sot, ten, razr, dec
 Dim i As Integer, str As String, s As String, str1 As String
 Dim intPart As String, frPart As String, prop As String
 Dim mlnEnd, tscEnd, razrEnd, rub, cop
 dec = Array("ноль ", "одна ", "две ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ed = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
 ten = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
 des = Array("", "", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
 sot = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
 razr = Array("", "тысяч", "миллион", "миллиард")
 mlnEnd = Array("ов ", " ", "а ", "а ", "а ", "ов ", "ов ", "ов ", "ов ", "ов ")
 tscEnd = Array(" ", "а ", "и ", "и ", "и ", " ", " ", " ", " ", " ")
 razrEnd = Array(mlnEnd, mlnEnd, tscEnd, "")
 rub = Array("рублей", "рубль", "рубля", "рубля", "рубля", "рублей", "рублей", "рублей", "рублей", "рублей")
 cop = Array("копеек", "копейка", "копейки", "копейки", "копейки", "копеек", "копеек", "копеек", "копеек", "копеек")
 If Сумма >= 1000000000000# Or Сумма < 0 Then РубПропись = CVErr(xlErrValue): Exit Function
 '&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
    If Round(Сумма, 2) >= 1 Then
        intPart = Left$(Format(Сумма, "000000000000.00"), 12)
        For i = 0 To 3
            s = Mid$(intPart, i * 3 + 1, 3)
                If s <> "000" Then
                    str = str & sot(CInt(Left$(s, 1)))
                        If Mid$(s, 2, 1) = "1" Then
                            str = str & ten(CInt(Right$(s, 1)))
                        Else
                            str = str & des(CInt(Mid$(s, 2, 1))) & IIf(i = 2, dec(CInt(Right$(s, 1))), ed(CInt(Right$(s, 1))))
                        End If
         On Error Resume Next
            str = str & IIf(Mid$(s, 2, 1) = "1", razr(3 - i) & razrEnd(i)(0), _
            razr(3 - i) & razrEnd(i)(CInt(Right$(s, 1))))
         On Error GoTo 0
                End If
 Next i
 frPart = Right$(Format(Сумма, "0.00"), 1)
  
 str = str & IIf(Mid$(s, 2, 1) = "1", rub(0), rub(CInt(Right$(s, 1))))
 str1 = IIf(Left$(frPart, 1) = "1", ten(CInt(Right$(frPart, 1))) & cop(0), _
 des(CInt(Left$(frPart, 1))) & dec(CInt(Right$(frPart, 1))) & cop(CInt(Right$(frPart, 1))))
 prop = str & " " & str1
 
 РубПропись = prop
 End If
 
End Function
 
 
 
Sub РубПропись2()
Dim Summa$
Summa$ = РубПропись(Selection.Text)
If Summa$ <> "" Then ' допустимое значение
Selection = Summa$
End If
End Sub

frPart = Right$(Format(Сумма, "0.00"), 2)

Option Explicit
 
Sub Proverka()
    MsgBox SumPropRU([c3])
End Sub
 
Function SumPropRU(ByVal Sum#) As String
    'Сумма прописью RU до триллионов, с копейками и рублями
 
    'Ниже валютные константы как для 1-го рубля, для двух рублей и для пяти рублей (окончания соответственно через минусы)
    Const Rub125 = "рубл-ь-я-ей", Cop125 = "копе-йка-йки-ек", p = " "
    Const r1 = "ноль од-ин-на дв-а-е три четыре пять шесть семь восемь девять десять одинадцать двенадцать тринадцать четырнадцать пятнадцать шеснадцать семнадцать весемнадцать девятнадцать"
    Const r2 = "двадцать тридцать сорок пятьдесят шестьдесят семьдесят восемьдесят девяносто"
    Const r3 = "сто двести триста четыреста пятьсот шестьсот семьсот восемьсот девятьсот"
    Const r4 = "тысяч-а-и- миллион--а-ов миллиард--а-ов триллион--а-ов"
    Dim a$(1), a1$(), a2$(), a3$(), a4$(), w1$(), w4$()
    Dim n#, s$, i&, j&, jj&, t&, ii&, valut$()
    
    
    a1 = Split(r1): a2 = Split(r2): a3 = Split(r3): a4 = Split(r4)
    Sum = Round(Sum, 2) 'Округлить до первых двух знаков после запятой
    valut = Split(CStr(Sum), ",") 'Разделить значения в две ячейки до и после запятой
    If UBound(valut) > 0 Then valut(1) = Left$(valut(1) & 0, 2) 'Добавить ноль после запятой и отсеч 2 первых знака
 
    For ii = 0 To UBound(valut) 'Цикл создания записи рублей и копеек
        n = valut(ii)
        For i = 0 To UBound(a4) + 1 'Цикл создания записи сумм
            j = Right$(CStr(n), 3): n = Fix(n / 1000): s = "": jj = j Mod 100: j = j \ 100
            If j > 0 Then s = s & a3(j - 1) & p
            Select Case jj
            Case 0: w1 = Split(a1(jj Mod 10), "-")
            Case Is < 20: w1 = Split(a1(jj), "-"): s = s & w1(0) & p
            Case Else: w1 = Split(a1(jj Mod 10), "-"): s = s & a2(jj \ 10 - 2) & IIf(jj Mod 10 <> 0, p & w1(0), "") & p
            End Select
            If i > 0 Then w4 = Split(a4(i - 1), "-") Else w4 = Split(Choose(ii + 1, Rub125, Cop125), "-")
            
            
            Select Case jj Mod 10
            Case 1
                If jj > 10 And jj < 20 Then GoTo MnCh
                If UBound(w1) > 0 Then s = RTrim(s) & w1(Abs(i = 1 Or ii = 1) + 1) & p
                s = s & w4(0) & w4(1) & p 'Запись слева направо
            Case 2, 3, 4
                If jj > 10 And jj < 20 Then GoTo MnCh
                If UBound(w1) > 0 Then s = RTrim(s) & w1(Abs(i = 1 Or ii = 1) + 1) & p
                s = s & w4(0) & w4(2) & p
            Case Else
MnCh:
                s = s & w4(0) & w4(3) & p
            End Select
            a(ii) = RTrim$(s) & ", " & a(ii)
            If n = 0 Then Exit For
        Next
        a(ii) = IIf(Left$(a(ii), 4) = Left$(Rub125, 4), w1(0) & p, "") & a(ii)
    Next
    SumPropRU = Join(a, "")  'Объеденить две записи справа налево
    SumPropRU = Left$(SumPropRU, InStrRev(SumPropRU, ",") - 1)
    SumPropRU = UCase(Left$(SumPropRU, 1)) & Mid$(SumPropRU, 2)
End Function